package File::DataClass::Functions;

use 5.010001;
use strict;
use warnings;
use feature 'state';

use English                    qw( -no_match_vars );
use Exporter 5.57              qw( import );
use File::DataClass::Constants qw( CYGWIN EVIL EXCEPTION_CLASS STORAGE_BASE
                                   STORAGE_EXCEPTIONS );
use Hash::Merge                qw( merge );
use List::Util                 qw( first );
use Module::Pluggable::Object;
use Module::Runtime            qw( require_module );
use Scalar::Util               qw( blessed );
use Try::Tiny;
use Unexpected::Functions      qw( is_class_loaded );

our @EXPORT_OK    = qw( ensure_class_loaded extension_map first_char
                        is_arrayref is_coderef is_hashref is_member
                        is_stale qualify_storage_class map_extension2class
                        merge_attributes merge_file_data supported_extensions
                        thread_id throw );
our %EXPORT_TAGS  =   ( all => [ @EXPORT_OK ], );

my $LC_OSNAME     = lc $OSNAME;
my $NTFS          = $LC_OSNAME eq EVIL || $LC_OSNAME eq CYGWIN ? 1 : 0;

# Public functions
sub ensure_class_loaded ($;$) {
   my ($class, $opts) = @_; $opts ||= {};

   not $opts->{ignore_loaded} and is_class_loaded( $class ) and return 1;

   try { require_module( $class ) } catch { throw( $_ ) };

   is_class_loaded( $class )
      or throw( error => 'Class [_1] loaded but package undefined',
                args  => [ $class ] );

   return 1;
}

sub extension_map (;$$) {
   my ($class, $extensions) = @_; state $map //= { '_map_loaded' => 0 };

   if (defined $class) {
      if (defined $extensions) { # uncoverable branch false
         is_arrayref( $extensions ) or $extensions = [ $extensions ];

         for my $extn (@{ $extensions }) {
            $map->{ $extn } //= []; is_member( $class, $map->{ $extn } )
               or push @{ $map->{ $extn } }, $class;
         }
      }

      return;
   }

   $map->{ '_map_loaded' } and return $map;

   my $base       = STORAGE_BASE;
   my $exceptions = STORAGE_EXCEPTIONS;
   my $finder     = Module::Pluggable::Object->new
      ( except => [ $exceptions ], search_path => [ $base ], require => 1, );

   $finder->plugins; $map->{ '_map_loaded' } = 1;

   return $map;
}

sub first_char ($) {
   return substr $_[ 0 ], 0, 1;
}

sub is_arrayref (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'ARRAY' ? 1 : 0;
}

sub is_coderef (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'CODE' ? 1 : 0;
}

sub is_hashref (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'HASH' ? 1 : 0;
}

sub is_member (;@) {
   my ($candidate, @args) = @_; $candidate or return;

   is_arrayref $args[ 0 ] and @args = @{ $args[ 0 ] };

   return (first { $_ eq $candidate } @args) ? 1 : 0;
}

sub is_stale (;$$$) {
   my ($data, $cache_mtime, $path_mtime) = @_;

   # Assume NTFS does not support mtime
   $NTFS and return 1; # uncoverable branch true

   my $is_def = defined $data && defined $path_mtime && defined $cache_mtime;

   return !$is_def || $path_mtime > $cache_mtime ? 1 : 0;
}

sub map_extension2class ($) {
   my $map = extension_map();

   return exists $map->{ $_[ 0 ] } ? $map->{ $_[ 0 ] } : undef;
}

sub merge_attributes ($$;$) {
   my ($dest, $src, $attrs) = @_; my $class = blessed $src;

   for (grep { not exists $dest->{ $_ } or not defined $dest->{ $_ } }
        @{ $attrs || [] }) {
      my $v = $class ? ($src->can( $_ ) ? $src->$_() : undef) : $src->{ $_ };

      defined $v and $dest->{ $_ } = $v;
   }

   return $dest;
}

sub merge_file_data ($$) {
   my ($existing, $new) = @_;

   for (keys %{ $new }) {
      $existing->{ $_ } = exists $existing->{ $_ }
                        ? merge( $existing->{ $_ }, $new->{ $_ } )
                        : $new->{ $_ };
   }

   return;
}

sub qualify_storage_class ($) {
   return STORAGE_BASE.'::'.$_[ 0 ];
}

sub supported_extensions () {
   return grep { not m{ \A _ }mx } keys %{ extension_map() };
}

sub thread_id () {
   # uncoverable branch true
   return exists $INC{ 'threads.pm' } ? threads->tid() : 0;
}

sub throw (;@) {
   EXCEPTION_CLASS->throw( @_ );
}

1;

__END__

=pod

=head1 Name

File::DataClass::Functions - Common functions used in this distribution

=head1 Synopsis

   use File::DataClass::Functions qw(list of functions to import);

=head1 Description

Common functions used in this distribution

=head1 Subroutines/Methods

=head2 ensure_class_loaded

   ensure_class_loaded( $some_class, \%options );

Require the requested class, throw an error if it doesn't load

=head2 extension_map

   $map   = extension_map;                     # Accessor
   $value = extension_map $class, $extensions; # Mutator

An accessor / mutator for the stateful hash reference that maps filename
extensions onto storage classes. Calling the accessor populates the
extension map on first use. Storage subclasses call the mutator to
register the extensions that they handle. If the C<$extensions>
parameter is an array reference then the storage subclass can
"claim ownership" of more than one extension in a single call

=head2 first_char

   $single_char = first_char $some_string;

Returns the first character of C<$string>

=head2 is_arrayref

   $bool = is_arrayref $scalar_variable

Tests to see if the scalar variable is an array ref

=head2 is_coderef

   $bool = is_coderef $scalar_variable

Tests to see if the scalar variable is a code ref

=head2 is_hashref

   $bool = is_hashref $scalar_variable

Tests to see if the scalar variable is a hash ref

=head2 is_member

   $bool = is_member q(test_value), qw(a_value test_value b_value);

Tests to see if the first parameter is present in the list of
remaining parameters

=head2 is_stale

   $bool = is_stale $data, $cache_mtime, $path_mtime;

Returns true if there is no data or the cache mtime is older than the
path mtime

=head2 map_extension2class

   $array_ref_of_class_name = map_extension2class $extension;

Maps a filename extensions to a storage classes

=head2 merge_attributes

   $dest = merge_attributes $dest, $src, $attr_list_ref;

Merges attribute hashes. The C<$dest> hash is updated and
returned. The C<$dest> hash values take precedence over the C<$src>
hash values. The C<$src> hash may be an object in which case its
accessor methods are called

=head2 merge_file_data

   merge_file_data $existing, $new;

Uses L<Hash::Merge> to merge data from the new hash ref in with the existing

=head2 qualify_storage_class

   $storage_classname = qualify_storage_class $class_suffix;

Prepends the C<STORAGE_BASE> classname to the supplied suffix

=head2 supported_extensions

   @list_of_extension_names = supported_extensions;

Returns a list of supported filename extensions

=head2 thread_id

   $thread_id = thread_id;

Returns the current thread id or zero if the the L<threads> module has
not been loaded

=head2 throw

   throw error => q(error_key), args => [ q(error_arg) ];

Expose L<CatalystX::Usul::Exception/throw>. C<CX::Usul::Functions> has a
class attribute I<Exception_Class> which can be set via a call to
C<set_inherited>

=head1 Configuration and Environment

None

=head1 Diagnostics

None

=head1 Dependencies

=over 3

=item L<Exporter>

=item L<Hash::Merge>

=item L<Module::Runtime>

=item L<Try::Tiny>

=item L<Unexpected>

=back

=head1 Incompatibilities

There are no known incompatibilities in this module

=head1 Bugs and Limitations

There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome

=head1 Acknowledgements

Larry Wall - For the Perl programming language

=head1 Author

Peter Flanigan, C<< <pjfl@cpan.org> >>

=head1 License and Copyright

Copyright (c) 2014 Peter Flanigan. All rights reserved

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>

This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE

=cut

# Local Variables:
# mode: perl
# tab-width: 3
# End:
