File Coverage

lib/File/DataClass/Functions.pm

Criterion	Covered	Total	%
statement	119	119	100.0
branch	49	54	96.3
condition	34	37	91.8
subroutine	34	34	100.0
pod	18	18	100.0
total	254	262	98.0

package File::DataClass::Functions;

use 5.010001;
use strict;
use warnings;

use English                    qw( -no_match_vars );
use Exporter 5.57              qw( import );
use File::DataClass::Constants qw( CYGWIN EXCEPTION_CLASS MSOFT 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 Unspecified );

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

my $LC_OSNAME = lc $OSNAME;

# Private functions
my $_merge_attr;

my $_merge_attr_arrays = sub {
   my ($to, $from) = @_; my $updated = 0;

   for (0 .. $#{ $to }) {
      if (defined $from->[ $_ ]) {
         my $res = $_merge_attr->( \$to->[ $_ ], $from->[ $_ ] );

         $updated ||= $res;
      }
      elsif ($to->[ $_ ]) { splice @{ $to }, $_; $updated = 1; last }
   }

   if (@{ $from } > @{ $to }) {
      push @{ $to }, (splice @{ $from }, $#{ $to } + 1); $updated = 1;
   }

   return $updated;
};

my $_merge_attr_hashes = sub {
   my ($to, $from) = @_; my $updated = 0;

   for (grep { exists $from->{ $_ } } keys %{ $to }) {
      if (defined $from->{ $_ }) {
         my $res = $_merge_attr->( \$to->{ $_ }, $from->{ $_ } );

         $updated ||= $res;
      }
      else { delete $to->{ $_ }; delete $from->{ $_ }; $updated = 1 }
   }

   for (grep { not exists $to->{ $_ } } keys %{ $from }) {
      if (defined $from->{ $_ }) {
         $to->{ $_ } = $from->{ $_ }; $updated = 1;
      }
   }

   return $updated;
};

$_merge_attr = sub {
   my ($to_ref, $from) = @_; my $to = ${ $to_ref }; my $updated = 0;

   if ($to and ref $to eq 'HASH') {
      $updated = $_merge_attr_hashes->( $to, $from );
   }
   elsif ($to and ref $to eq 'ARRAY') {
      $updated = $_merge_attr_arrays->( $to, $from );
   }
   elsif (defined $to and $to ne $from) {
      $updated = 1; ${ $to_ref } = $from;
   }
   elsif (not defined $to) {
      if (ref $from eq 'HASH') {
         scalar keys %{ $from } > 0 and $updated = 1
            and ${ $to_ref } = $from;
      }
      elsif (ref $from eq 'ARRAY') {
         scalar @{ $from } > 0 and $updated = 1 and ${ $to_ref } = $from;
      }
      else { $updated = 1; ${ $to_ref } = $from }
   }

   return $updated;
};

# 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( 'Class [_1] loaded but package undefined', [ $class ] );

   return 1;
}

{  my $_extension_map = { '_map_loaded' => 0 };

   sub extension_map (;$$) {
      my ($class, $extensions) = @_;

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

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

         return;
      }

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

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

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

      return $_extension_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_mswin () {
   return $LC_OSNAME eq MSOFT ? 1 : 0;
}

sub is_ntfs () {
   return  is_mswin || $LC_OSNAME eq CYGWIN ? 1 : 0;
}

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

   # Assume NTFS does not support mtime
   is_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 merge_for_update (;$$$) {
   my ($dest_ref, $src, $filter) = @_; my $updated = 0;

   $dest_ref or throw( Unspecified, [ 'destination reference' ] );

   ${ $dest_ref } //= {}; $src //= {}; $filter //= sub { keys %{ $_[ 0 ] } };

   for my $k ($filter->( $src )) {
      if (defined $src->{ $k }) {
         my $res = $_merge_attr->( \${ $dest_ref }->{ $k }, $src->{ $k } );

         $updated ||= $res;
      }
      elsif (exists ${ $dest_ref }->{ $k }) {
         delete ${ $dest_ref }->{ $k }; $updated = 1;
      }
   }

   return $updated;
}

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__