Initial Commit

database/perl/vendor/lib/Test/File/ShareDir/TempDirObject.pm

@@ -0,0 +1,206 @@
+use 5.006;    # pragmas
+use strict;
+use warnings;
+
+package Test::File::ShareDir::TempDirObject;
+
+our $VERSION = '1.001002';
+
+# ABSTRACT: Internal Object to make code simpler.
+
+our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
+
+
+
+
+
+
+
+
+
+
+
+
+use Path::Tiny qw(path);
+use Carp qw(confess);
+## no critic (Subroutines::RequireArgUnpacking)
+sub __rcopy { require File::Copy::Recursive; goto \&File::Copy::Recursive::rcopy; }
+
+
+
+
+
+
+
+sub new {
+  my ( $class, $config ) = @_;
+
+  confess('Need -share => for Test::File::ShareDir') unless exists $config->{-share};
+
+  my $realconfig = {
+    root    => path(q{./})->absolute,    #->resolve->absolute,
+    modules => {},
+    dists   => {},
+  };
+
+  $realconfig->{root}    = path( delete $config->{-root} )->absolute if exists $config->{-root};
+  $realconfig->{modules} = delete $config->{-share}->{-module}       if exists $config->{-share}->{-module};
+  $realconfig->{dists}   = delete $config->{-share}->{-dist}         if exists $config->{-share}->{-dist};
+
+  confess( 'Unsupported -share types : ' . join q{ }, keys %{ $config->{-share} } ) if keys %{ $config->{-share} };
+
+  delete $config->{-share};
+
+  confess( 'Unsupported parameter to import() : ' . join q{ }, keys %{$config} ) if keys %{$config};
+
+  return bless $realconfig, $class;
+}
+
+my @cache;
+
+sub _tempdir {
+  my ($self) = shift;
+  return $self->{tempdir} if exists $self->{tempdir};
+  $self->{tempdir} = Path::Tiny::tempdir( CLEANUP => 1 );
+
+  # Explicit keepalive till GC
+  push @cache, $self->{tempdir};
+  return $self->{tempdir};
+}
+
+sub _module_tempdir {
+  my ($self) = shift;
+  return $self->{module_tempdir} if exists $self->{module_tempdir};
+  $self->{module_tempdir} = $self->_tempdir->child('auto/share/module');
+  $self->{module_tempdir}->mkpath();
+  return $self->{module_tempdir}->absolute;
+}
+
+sub _dist_tempdir {
+  my ($self) = shift;
+  return $self->{dist_tempdir} if exists $self->{dist_tempdir};
+  $self->{dist_tempdir} = $self->_tempdir->child('auto/share/dist');
+  $self->{dist_tempdir}->mkpath();
+  return $self->{dist_tempdir}->absolute;
+}
+
+sub _root {
+  my ($self) = shift;
+  return $self->{root};
+}
+
+sub _modules { return shift->{modules}; }
+
+sub _dists { return shift->{dists} }
+
+sub _module_names {
+  my ($self) = shift;
+  return keys %{ $self->_modules };
+}
+
+sub _dist_names {
+  my ($self) = shift;
+  return keys %{ $self->_dists };
+}
+
+sub _module_share_target_dir {
+  my ( $self, $modname ) = @_;
+
+  ## no critic (RegularExpressions)
+  $modname =~ s/::/-/g;
+
+  return $self->_module_tempdir->child($modname);
+}
+
+sub _dist_share_target_dir {
+  my ( $self, $distname ) = @_;
+  return $self->_dist_tempdir->child($distname);
+}
+
+sub _module_share_source_dir {
+  my ( $self, $module ) = @_;
+  return path( $self->_modules->{$module} )->absolute( $self->_root );
+}
+
+sub _dist_share_source_dir {
+  my ( $self, $dist ) = @_;
+  return path( $self->_dists->{$dist} )->absolute( $self->_root );
+}
+
+sub _install_module {
+  my ( $self, $module ) = @_;
+  return __rcopy( $self->_module_share_source_dir($module), $self->_module_share_target_dir($module) );
+}
+
+sub _install_dist {
+  my ( $self, $dist ) = @_;
+  return __rcopy( $self->_dist_share_source_dir($dist), $self->_dist_share_target_dir($dist) );
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test::File::ShareDir::TempDirObject - Internal Object to make code simpler.
+
+=head1 VERSION
+
+version 1.001002
+
+=head1 SYNOPSIS
+
+    my $object = $class->new({
+        -root => 'foo', # optional
+        -share => {
+            -module => {
+                'baz' => 'dir',
+            },
+            -dist => {
+                'Task-baz' => 'otherdir',
+            },
+        },
+    });
+
+    # installs a sharedir for 'baz' by copying 'foo/dir'
+    $object->_install_module('baz');
+
+    # installs a shardir for distribution 'Task-baz' by copying 'foo/otherdir'
+    $object->_install_dist('Task-baz');
+
+    # add to @INC
+    unshift @INC, $object->_tempdir->stringify;
+
+=head1 METHODS
+
+=head2 new
+
+Creates a new instance of this object.
+
+=begin MetaPOD::JSON v1.1.0
+
+{
+    "namespace":"Test::File::ShareDir::TempDirObject",
+    "interface":"class"
+}
+
+
+=end MetaPOD::JSON
+
+=head1 AUTHOR
+
+Kent Fredric <kentnl@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2017 by Kent Fredric <kentnl@cpan.org>.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut