Initial Commit
This commit is contained in:
Riley Schneider
240
database/perl/vendor/lib/File/CheckTree.pm
vendored
Normal file
240
database/perl/vendor/lib/File/CheckTree.pm
vendored
Normal file
@@ -0,0 +1,240 @@
|
||||
package File::CheckTree;
|
||||
|
||||
use 5.006;
|
||||
use Cwd;
|
||||
use Exporter;
|
||||
use File::Spec;
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use if $] > 5.017, 'deprecate';
|
||||
|
||||
our $VERSION = '4.42';
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(validate);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::CheckTree - run many filetest checks on a tree
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::CheckTree;
|
||||
|
||||
$num_warnings = validate( q{
|
||||
/vmunix -e || die
|
||||
/boot -e || die
|
||||
/bin cd
|
||||
csh -ex
|
||||
csh !-ug
|
||||
sh -ex
|
||||
sh !-ug
|
||||
/usr -d || warn "What happened to $file?\n"
|
||||
});
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The validate() routine takes a single multiline string consisting of
|
||||
directives, each containing a filename plus a file test to try on it.
|
||||
(The file test may also be a "cd", causing subsequent relative filenames
|
||||
to be interpreted relative to that directory.) After the file test
|
||||
you may put C<|| die> to make it a fatal error if the file test fails.
|
||||
The default is C<|| warn>. The file test may optionally have a "!' prepended
|
||||
to test for the opposite condition. If you do a cd and then list some
|
||||
relative filenames, you may want to indent them slightly for readability.
|
||||
If you supply your own die() or warn() message, you can use $file to
|
||||
interpolate the filename.
|
||||
|
||||
Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
|
||||
Only the first failed test of the bunch will produce a warning.
|
||||
|
||||
The routine returns the number of warnings issued.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
File::CheckTree was derived from lib/validate.pl which was
|
||||
written by Larry Wall.
|
||||
Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
File::CheckTree used to not display fatal error messages.
|
||||
It used to count only those warnings produced by a generic C<|| warn>
|
||||
(and not those in which the user supplied the message). In addition,
|
||||
the validate() routine would leave the user program in whatever
|
||||
directory was last entered through the use of "cd" directives.
|
||||
These bugs were fixed during the development of perl 5.8.
|
||||
The first fixed version of File::CheckTree was 4.2.
|
||||
|
||||
=cut
|
||||
|
||||
my $Warnings;
|
||||
|
||||
sub validate {
|
||||
my ($starting_dir, $file, $test, $cwd, $oldwarnings);
|
||||
|
||||
$starting_dir = cwd;
|
||||
|
||||
$cwd = "";
|
||||
$Warnings = 0;
|
||||
|
||||
foreach my $check (split /\n/, $_[0]) {
|
||||
my ($testlist, @testlist);
|
||||
|
||||
# skip blanks/comments
|
||||
next if $check =~ /^\s*#/ || $check =~ /^\s*$/;
|
||||
|
||||
# Todo:
|
||||
# should probably check for invalid directives and die
|
||||
# but earlier versions of File::CheckTree did not do this either
|
||||
|
||||
# split a line like "/foo -r || die"
|
||||
# so that $file is "/foo", $test is "-r || die"
|
||||
# (making special allowance for quoted filenames).
|
||||
if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or
|
||||
$check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or
|
||||
$check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/)
|
||||
{
|
||||
($file, $test) = ($1,$2);
|
||||
}
|
||||
else {
|
||||
die "Malformed line: '$check'";
|
||||
};
|
||||
|
||||
# change a $test like "!-ug || die" to "!-Z || die",
|
||||
# capturing the bundled tests (e.g. "ug") in $2
|
||||
if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
|
||||
$testlist = $2;
|
||||
# split bundled tests, e.g. "ug" to 'u', 'g'
|
||||
@testlist = split(//, $testlist);
|
||||
}
|
||||
else {
|
||||
# put in placeholder Z for stand-alone test
|
||||
@testlist = ('Z');
|
||||
}
|
||||
|
||||
# will compare these two later to stop on 1st warning w/in a bundle
|
||||
$oldwarnings = $Warnings;
|
||||
|
||||
foreach my $one (@testlist) {
|
||||
# examples of $test: "!-Z || die" or "-w || warn"
|
||||
my $this = $test;
|
||||
|
||||
# expand relative $file to full pathname if preceded by cd directive
|
||||
$file = File::Spec->catfile($cwd, $file)
|
||||
if $cwd && !File::Spec->file_name_is_absolute($file);
|
||||
|
||||
# put filename in after the test operator
|
||||
$this =~ s/(-\w\b)/$1 "\$file"/g;
|
||||
|
||||
# change the "-Z" representing a bundle with the $one test
|
||||
$this =~ s/-Z/-$one/;
|
||||
|
||||
# if it's a "cd" directive...
|
||||
if ($this =~ /^cd\b/) {
|
||||
# add "|| die ..."
|
||||
$this .= ' || die "cannot cd to $file\n"';
|
||||
# expand "cd" directive with directory name
|
||||
$this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
|
||||
}
|
||||
else {
|
||||
# add "|| warn" as a default disposition
|
||||
$this .= ' || warn' unless $this =~ /\|\|/;
|
||||
|
||||
# change a generic ".. || die" or ".. || warn"
|
||||
# to call valmess instead of die/warn directly
|
||||
# valmess will look up the error message from %Val_Message
|
||||
$this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
|
||||
/$1 || valmess('$3', '$2', \$file)/x;
|
||||
}
|
||||
|
||||
{
|
||||
# count warnings, either from valmess or '-r || warn "my msg"'
|
||||
# also, call any pre-existing signal handler for __WARN__
|
||||
my $orig_sigwarn = $SIG{__WARN__};
|
||||
local $SIG{__WARN__} = sub {
|
||||
++$Warnings;
|
||||
if ( $orig_sigwarn ) {
|
||||
$orig_sigwarn->(@_);
|
||||
}
|
||||
else {
|
||||
warn "@_";
|
||||
}
|
||||
};
|
||||
|
||||
# do the test
|
||||
eval $this;
|
||||
|
||||
# re-raise an exception caused by a "... || die" test
|
||||
if (my $err = $@) {
|
||||
# in case of any cd directives, return from whence we came
|
||||
if ($starting_dir ne cwd) {
|
||||
chdir($starting_dir) || die "$starting_dir: $!";
|
||||
}
|
||||
die $err;
|
||||
}
|
||||
}
|
||||
|
||||
# stop on 1st warning within a bundle of tests
|
||||
last if $Warnings > $oldwarnings;
|
||||
}
|
||||
}
|
||||
|
||||
# in case of any cd directives, return from whence we came
|
||||
if ($starting_dir ne cwd) {
|
||||
chdir($starting_dir) || die "chdir $starting_dir: $!";
|
||||
}
|
||||
|
||||
return $Warnings;
|
||||
}
|
||||
|
||||
my %Val_Message = (
|
||||
'r' => "is not readable by uid $>.",
|
||||
'w' => "is not writable by uid $>.",
|
||||
'x' => "is not executable by uid $>.",
|
||||
'o' => "is not owned by uid $>.",
|
||||
'R' => "is not readable by you.",
|
||||
'W' => "is not writable by you.",
|
||||
'X' => "is not executable by you.",
|
||||
'O' => "is not owned by you.",
|
||||
'e' => "does not exist.",
|
||||
'z' => "does not have zero size.",
|
||||
's' => "does not have non-zero size.",
|
||||
'f' => "is not a plain file.",
|
||||
'd' => "is not a directory.",
|
||||
'l' => "is not a symbolic link.",
|
||||
'p' => "is not a named pipe (FIFO).",
|
||||
'S' => "is not a socket.",
|
||||
'b' => "is not a block special file.",
|
||||
'c' => "is not a character special file.",
|
||||
'u' => "does not have the setuid bit set.",
|
||||
'g' => "does not have the setgid bit set.",
|
||||
'k' => "does not have the sticky bit set.",
|
||||
'T' => "is not a text file.",
|
||||
'B' => "is not a binary file."
|
||||
);
|
||||
|
||||
sub valmess {
|
||||
my ($disposition, $test, $file) = @_;
|
||||
my $ferror;
|
||||
|
||||
if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
|
||||
my ($neg, $ftype) = ($1, $2);
|
||||
|
||||
$ferror = "$file $Val_Message{$ftype}";
|
||||
|
||||
if ($neg eq '!') {
|
||||
$ferror =~ s/ is not / should not be / ||
|
||||
$ferror =~ s/ does not / should not / ||
|
||||
$ferror =~ s/ not / /;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$ferror = "Can't do $test $file.\n";
|
||||
}
|
||||
|
||||
die "$ferror\n" if $disposition eq 'die';
|
||||
warn "$ferror\n";
|
||||
}
|
||||
|
||||
1;
|
||||
808
database/perl/vendor/lib/File/Copy/Recursive.pm
vendored
Normal file
808
database/perl/vendor/lib/File/Copy/Recursive.pm
vendored
Normal file
@@ -0,0 +1,808 @@
|
||||
package File::Copy::Recursive;
|
||||
|
||||
use strict;
|
||||
|
||||
BEGIN {
|
||||
# Keep older versions of Perl from trying to use lexical warnings
|
||||
$INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006;
|
||||
}
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
use File::Copy;
|
||||
use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
|
||||
use Cwd ();
|
||||
|
||||
use vars qw(
|
||||
@ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink
|
||||
$PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
|
||||
$CondCopy $BdTrgWrn $SkipFlop $DirPerms
|
||||
);
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob);
|
||||
|
||||
$VERSION = '0.45';
|
||||
|
||||
$MaxDepth = 0;
|
||||
$KeepMode = 1;
|
||||
$CPRFComp = 0;
|
||||
$CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0;
|
||||
$PFSCheck = 1;
|
||||
$RemvBase = 0;
|
||||
$NoFtlPth = 0;
|
||||
$ForcePth = 0;
|
||||
$CopyLoop = 0;
|
||||
$RMTrgFil = 0;
|
||||
$RMTrgDir = 0;
|
||||
$CondCopy = {};
|
||||
$BdTrgWrn = 0;
|
||||
$SkipFlop = 0;
|
||||
$DirPerms = 0777;
|
||||
|
||||
my $samecheck = sub {
|
||||
return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders...
|
||||
return if @_ != 2 || !defined $_[0] || !defined $_[1];
|
||||
return if $_[0] eq $_[1];
|
||||
|
||||
my $one = '';
|
||||
if ($PFSCheck) {
|
||||
$one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || '';
|
||||
my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || '';
|
||||
if ( $one eq $two && $one ) {
|
||||
carp "$_[0] and $_[1] are identical";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
if ( -d $_[0] && !$CopyLoop ) {
|
||||
$one = join( '-', ( stat $_[0] )[ 0, 1 ] ) if !$one;
|
||||
my $abs = File::Spec->rel2abs( $_[1] );
|
||||
my @pth = File::Spec->splitdir($abs);
|
||||
while (@pth) {
|
||||
if ( $pth[-1] eq '..' ) { # cheaper than Cwd::realpath() plus we don't want to resolve symlinks at this point, right?
|
||||
pop @pth;
|
||||
pop @pth unless -l File::Spec->catdir(@pth);
|
||||
next;
|
||||
}
|
||||
my $cur = File::Spec->catdir(@pth);
|
||||
last if !$cur; # probably not necessary, but nice to have just in case :)
|
||||
my $two = join( '-', ( stat $cur )[ 0, 1 ] ) || '';
|
||||
if ( $one eq $two && $one ) {
|
||||
|
||||
# $! = 62; # Too many levels of symbolic links
|
||||
carp "Caught Deep Recursion Condition: $_[0] contains $_[1]";
|
||||
return;
|
||||
}
|
||||
|
||||
pop @pth;
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
};
|
||||
|
||||
my $glob = sub {
|
||||
my ( $do, $src_glob, @args ) = @_;
|
||||
|
||||
local $CPRFComp = 1;
|
||||
require File::Glob;
|
||||
|
||||
my @rt;
|
||||
for my $path ( File::Glob::bsd_glob($src_glob) ) {
|
||||
my @call = [ $do->( $path, @args ) ] or return;
|
||||
push @rt, \@call;
|
||||
}
|
||||
|
||||
return @rt;
|
||||
};
|
||||
|
||||
my $move = sub {
|
||||
my $fl = shift;
|
||||
my @x;
|
||||
if ($fl) {
|
||||
@x = fcopy(@_) or return;
|
||||
}
|
||||
else {
|
||||
@x = dircopy(@_) or return;
|
||||
}
|
||||
if (@x) {
|
||||
if ($fl) {
|
||||
unlink $_[0] or return;
|
||||
}
|
||||
else {
|
||||
pathrmdir( $_[0] ) or return;
|
||||
}
|
||||
if ($RemvBase) {
|
||||
my ( $volm, $path ) = File::Spec->splitpath( $_[0] );
|
||||
pathrm( File::Spec->catpath( $volm, $path, '' ), $ForcePth, $NoFtlPth ) or return;
|
||||
}
|
||||
}
|
||||
return wantarray ? @x : $x[0];
|
||||
};
|
||||
|
||||
my $ok_todo_asper_condcopy = sub {
|
||||
my $org = shift;
|
||||
my $copy = 1;
|
||||
if ( exists $CondCopy->{$org} ) {
|
||||
if ( $CondCopy->{$org}{'md5'} ) {
|
||||
|
||||
}
|
||||
if ($copy) {
|
||||
|
||||
}
|
||||
}
|
||||
return $copy;
|
||||
};
|
||||
|
||||
sub fcopy {
|
||||
$samecheck->(@_) or return;
|
||||
if ( $RMTrgFil && ( -d $_[1] || -e $_[1] ) ) {
|
||||
my $trg = $_[1];
|
||||
if ( -d $trg ) {
|
||||
my @trgx = File::Spec->splitpath( $_[0] );
|
||||
$trg = File::Spec->catfile( $_[1], $trgx[$#trgx] );
|
||||
}
|
||||
$samecheck->( $_[0], $trg ) or return;
|
||||
if ( -e $trg ) {
|
||||
if ( $RMTrgFil == 1 ) {
|
||||
unlink $trg or carp "\$RMTrgFil failed: $!";
|
||||
}
|
||||
else {
|
||||
unlink $trg or return;
|
||||
}
|
||||
}
|
||||
}
|
||||
my ( $volm, $path ) = File::Spec->splitpath( $_[1] );
|
||||
if ( $path && !-d $path ) {
|
||||
pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth );
|
||||
}
|
||||
if ( -l $_[0] && $CopyLink ) {
|
||||
my $target = readlink( shift() );
|
||||
($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
|
||||
carp "Copying a symlink ($_[0]) whose target does not exist"
|
||||
if !-e $target && $BdTrgWrn;
|
||||
my $new = shift();
|
||||
unlink $new if -l $new;
|
||||
symlink( $target, $new ) or return;
|
||||
}
|
||||
elsif ( -d $_[0] && -f $_[1] ) {
|
||||
return;
|
||||
}
|
||||
else {
|
||||
return if -d $_[0]; # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866
|
||||
copy(@_) or return;
|
||||
|
||||
my @base_file = File::Spec->splitpath( $_[0] );
|
||||
my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1];
|
||||
|
||||
chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode;
|
||||
}
|
||||
return wantarray ? ( 1, 0, 0 ) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings
|
||||
}
|
||||
|
||||
sub rcopy {
|
||||
if ( -l $_[0] && $CopyLink ) {
|
||||
goto &fcopy;
|
||||
}
|
||||
|
||||
goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
|
||||
goto &fcopy;
|
||||
}
|
||||
|
||||
sub rcopy_glob {
|
||||
$glob->( \&rcopy, @_ );
|
||||
}
|
||||
|
||||
sub dircopy {
|
||||
if ( $RMTrgDir && -d $_[1] ) {
|
||||
if ( $RMTrgDir == 1 ) {
|
||||
pathrmdir( $_[1] ) or carp "\$RMTrgDir failed: $!";
|
||||
}
|
||||
else {
|
||||
pathrmdir( $_[1] ) or return;
|
||||
}
|
||||
}
|
||||
my $globstar = 0;
|
||||
my $_zero = $_[0];
|
||||
my $_one = $_[1];
|
||||
if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*' ) {
|
||||
$globstar = 1;
|
||||
$_zero = substr( $_zero, 0, ( length($_zero) - 1 ) );
|
||||
}
|
||||
|
||||
$samecheck->( $_zero, $_[1] ) or return;
|
||||
if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
|
||||
$! = 20;
|
||||
return;
|
||||
}
|
||||
|
||||
if ( !-d $_[1] ) {
|
||||
pathmk( $_[1], $NoFtlPth ) or return;
|
||||
}
|
||||
else {
|
||||
if ( $CPRFComp && !$globstar ) {
|
||||
my @parts = File::Spec->splitdir($_zero);
|
||||
while ( $parts[$#parts] eq '' ) { pop @parts; }
|
||||
$_one = File::Spec->catdir( $_[1], $parts[$#parts] );
|
||||
}
|
||||
}
|
||||
my $baseend = $_one;
|
||||
my $level = 0;
|
||||
my $filen = 0;
|
||||
my $dirn = 0;
|
||||
|
||||
my $recurs; #must be my()ed before sub {} since it calls itself
|
||||
$recurs = sub {
|
||||
my ( $str, $end, $buf ) = @_;
|
||||
$filen++ if $end eq $baseend;
|
||||
$dirn++ if $end eq $baseend;
|
||||
|
||||
$DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
|
||||
mkdir( $end, $DirPerms ) or return if !-d $end;
|
||||
if ( $MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth ) {
|
||||
chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
|
||||
return ( $filen, $dirn, $level ) if wantarray;
|
||||
return $filen;
|
||||
}
|
||||
|
||||
$level++;
|
||||
|
||||
my @files;
|
||||
if ( $] < 5.006 ) {
|
||||
opendir( STR_DH, $str ) or return;
|
||||
@files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH) );
|
||||
closedir STR_DH;
|
||||
}
|
||||
else {
|
||||
opendir( my $str_dh, $str ) or return;
|
||||
@files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) );
|
||||
closedir $str_dh;
|
||||
}
|
||||
|
||||
for my $file (@files) {
|
||||
my ($file_ut) = $file =~ m{ (.*) }xms;
|
||||
my $org = File::Spec->catfile( $str, $file_ut );
|
||||
my $new = File::Spec->catfile( $end, $file_ut );
|
||||
if ( -l $org && $CopyLink ) {
|
||||
my $target = readlink($org);
|
||||
($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
|
||||
carp "Copying a symlink ($org) whose target does not exist"
|
||||
if !-e $target && $BdTrgWrn;
|
||||
unlink $new if -l $new;
|
||||
symlink( $target, $new ) or return;
|
||||
}
|
||||
elsif ( -d $org ) {
|
||||
my $rc;
|
||||
if ( !-w $org && $KeepMode ) {
|
||||
local $KeepMode = 0;
|
||||
$rc = $recurs->( $org, $new, $buf ) if defined $buf;
|
||||
$rc = $recurs->( $org, $new ) if !defined $buf;
|
||||
chmod scalar( ( stat($org) )[2] ), $new;
|
||||
}
|
||||
else {
|
||||
$rc = $recurs->( $org, $new, $buf ) if defined $buf;
|
||||
$rc = $recurs->( $org, $new ) if !defined $buf;
|
||||
}
|
||||
if ( !$rc ) {
|
||||
if ($SkipFlop) {
|
||||
next;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
$filen++;
|
||||
$dirn++;
|
||||
}
|
||||
else {
|
||||
if ( $ok_todo_asper_condcopy->($org) ) {
|
||||
if ($SkipFlop) {
|
||||
fcopy( $org, $new, $buf ) or next if defined $buf;
|
||||
fcopy( $org, $new ) or next if !defined $buf;
|
||||
}
|
||||
else {
|
||||
fcopy( $org, $new, $buf ) or return if defined $buf;
|
||||
fcopy( $org, $new ) or return if !defined $buf;
|
||||
}
|
||||
chmod scalar( ( stat($org) )[2] ), $new if $KeepMode;
|
||||
$filen++;
|
||||
}
|
||||
}
|
||||
}
|
||||
$level--;
|
||||
chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
|
||||
1;
|
||||
|
||||
};
|
||||
|
||||
$recurs->( $_zero, $_one, $_[2] ) or return;
|
||||
return wantarray ? ( $filen, $dirn, $level ) : $filen;
|
||||
}
|
||||
|
||||
sub fmove { $move->( 1, @_ ) }
|
||||
|
||||
sub rmove {
|
||||
if ( -l $_[0] && $CopyLink ) {
|
||||
goto &fmove;
|
||||
}
|
||||
|
||||
goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
|
||||
goto &fmove;
|
||||
}
|
||||
|
||||
sub rmove_glob {
|
||||
$glob->( \&rmove, @_ );
|
||||
}
|
||||
|
||||
sub dirmove { $move->( 0, @_ ) }
|
||||
|
||||
sub pathmk {
|
||||
my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() );
|
||||
my $nofatal = shift;
|
||||
|
||||
$DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
|
||||
|
||||
if ( defined($dir) ) {
|
||||
my (@dirs) = File::Spec->splitdir($dir);
|
||||
|
||||
for ( my $i = 0; $i < scalar(@dirs); $i++ ) {
|
||||
my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] );
|
||||
my $newpth = File::Spec->catpath( $vol, $newdir, "" );
|
||||
|
||||
mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
|
||||
mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
|
||||
}
|
||||
}
|
||||
|
||||
if ( defined($file) ) {
|
||||
my $newpth = File::Spec->catpath( $vol, $dir, $file );
|
||||
|
||||
mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
|
||||
mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub pathempty {
|
||||
my $pth = shift;
|
||||
|
||||
my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ];
|
||||
return 2 if !-d _ || !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); #stat.inode is 0 on Windows
|
||||
|
||||
my $starting_point = Cwd::cwd();
|
||||
my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ];
|
||||
chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!");
|
||||
$pth = '.';
|
||||
_bail_if_changed( $pth, $orig_dev, $orig_ino );
|
||||
|
||||
my @names;
|
||||
my $pth_dh;
|
||||
if ( $] < 5.006 ) {
|
||||
opendir( PTH_DH, $pth ) or return;
|
||||
@names = grep !/^\.\.?$/, readdir(PTH_DH);
|
||||
closedir PTH_DH;
|
||||
}
|
||||
else {
|
||||
opendir( $pth_dh, $pth ) or return;
|
||||
@names = grep !/^\.\.?$/, readdir($pth_dh);
|
||||
closedir $pth_dh;
|
||||
}
|
||||
_bail_if_changed( $pth, $orig_dev, $orig_ino );
|
||||
|
||||
for my $name (@names) {
|
||||
my ($name_ut) = $name =~ m{ (.*) }xms;
|
||||
my $flpth = File::Spec->catdir( $pth, $name_ut );
|
||||
|
||||
if ( -l $flpth ) {
|
||||
_bail_if_changed( $pth, $orig_dev, $orig_ino );
|
||||
unlink $flpth or return;
|
||||
}
|
||||
elsif ( -d $flpth ) {
|
||||
_bail_if_changed( $pth, $orig_dev, $orig_ino );
|
||||
pathrmdir($flpth) or return;
|
||||
}
|
||||
else {
|
||||
_bail_if_changed( $pth, $orig_dev, $orig_ino );
|
||||
unlink $flpth or return;
|
||||
}
|
||||
}
|
||||
|
||||
chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!");
|
||||
_bail_if_changed( ".", $starting_dev, $starting_ino );
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub pathrm {
|
||||
my ( $path, $force, $nofail ) = @_;
|
||||
|
||||
my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ];
|
||||
return 2 if !-d _ || !defined($orig_dev) || !$orig_ino;
|
||||
|
||||
# Manual test (I hate this function :/):
|
||||
# sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo
|
||||
if ( $force && File::Spec->file_name_is_absolute($path) ) {
|
||||
Carp::croak("pathrm() w/ force on abspath is not allowed");
|
||||
}
|
||||
|
||||
my @pth = File::Spec->splitdir($path);
|
||||
|
||||
my %fs_check;
|
||||
my $aggregate_path;
|
||||
for my $part (@pth) {
|
||||
$aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part;
|
||||
$fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ];
|
||||
}
|
||||
|
||||
while (@pth) {
|
||||
my $cur = File::Spec->catdir(@pth);
|
||||
last if !$cur; # necessary ???
|
||||
|
||||
if ($force) {
|
||||
_bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
|
||||
if ( !pathempty($cur) ) {
|
||||
return unless $nofail;
|
||||
}
|
||||
}
|
||||
_bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
|
||||
if ($nofail) {
|
||||
rmdir $cur;
|
||||
}
|
||||
else {
|
||||
rmdir $cur or return;
|
||||
}
|
||||
pop @pth;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub pathrmdir {
|
||||
my $dir = shift;
|
||||
if ( -e $dir ) {
|
||||
return if !-d $dir;
|
||||
}
|
||||
else {
|
||||
return 2;
|
||||
}
|
||||
|
||||
my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ];
|
||||
return 2 if !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino );
|
||||
|
||||
pathempty($dir) or return;
|
||||
_bail_if_changed( $dir, $orig_dev, $orig_ino );
|
||||
rmdir $dir or return;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _bail_if_changed {
|
||||
my ( $path, $orig_dev, $orig_ino ) = @_;
|
||||
|
||||
my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ];
|
||||
|
||||
if ( !defined $cur_dev || !defined $cur_ino ) {
|
||||
$cur_dev ||= "undef(path went away?)";
|
||||
$cur_ino ||= "undef(path went away?)";
|
||||
}
|
||||
else {
|
||||
$path = Cwd::abs_path($path);
|
||||
}
|
||||
|
||||
if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) {
|
||||
local $Carp::CarpLevel += 1;
|
||||
Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting");
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Copy::Recursive - Perl extension for recursively copying files and directories
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove);
|
||||
|
||||
fcopy($orig,$new[,$buf]) or die $!;
|
||||
rcopy($orig,$new[,$buf]) or die $!;
|
||||
dircopy($orig,$new[,$buf]) or die $!;
|
||||
|
||||
fmove($orig,$new[,$buf]) or die $!;
|
||||
rmove($orig,$new[,$buf]) or die $!;
|
||||
dirmove($orig,$new[,$buf]) or die $!;
|
||||
|
||||
rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!;
|
||||
rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode.
|
||||
|
||||
=head1 EXPORT
|
||||
|
||||
None by default. But you can export all the functions as in the example above and the path* functions if you wish.
|
||||
|
||||
=head2 fcopy()
|
||||
|
||||
This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be.
|
||||
One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below)
|
||||
The optional $buf in the synopsis is the same as File::Copy::copy()'s 3rd argument.
|
||||
This function returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomodate rcopy()'s list context on regular files. (See below for more info)
|
||||
|
||||
=head2 dircopy()
|
||||
|
||||
This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory.
|
||||
$new is created if necessary (multiple non existent directories is ok (i.e. foo/bar/baz). The script logically and portably creates all of them if necessary).
|
||||
It attempts to preserve the mode (see Preserving Mode below) and
|
||||
by default it copies all the way down into the directory (see Managing Depth, below).
|
||||
If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified.
|
||||
|
||||
This function returns true or false: for true in scalar context it returns the number of files and directories copied,
|
||||
whereas in list context it returns the number of files and directories, number of directories only, depth level traversed.
|
||||
|
||||
my $num_of_files_and_dirs = dircopy($orig,$new);
|
||||
my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new);
|
||||
|
||||
Normally it stops and returns if a copy fails. To continue on regardless, set $File::Copy::Recursive::SkipFlop to true.
|
||||
|
||||
local $File::Copy::Recursive::SkipFlop = 1;
|
||||
|
||||
That way it will copy everythging it can in a directory and won't stop because of permissions, etc...
|
||||
|
||||
=head2 rcopy()
|
||||
|
||||
This function will allow you to specify a file *or* a directory. It calls fcopy() if you passed file and dircopy() if you passed a directory.
|
||||
If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used.
|
||||
This is important because if it's a directory in list context and there is only the initial directory the return value is 1,1,1.
|
||||
|
||||
=head2 rcopy_glob()
|
||||
|
||||
This function lets you specify a pattern suitable for perl's File::Glob::bsd_glob() as the first argument. Subsequently each path returned by perl's File::Glob::bsd_glob() gets rcopy()ied.
|
||||
|
||||
It returns and array whose items are array refs that contain the return value of each rcopy() call.
|
||||
|
||||
It forces behavior as if $File::Copy::Recursive::CPRFComp is true.
|
||||
|
||||
=head2 fmove()
|
||||
|
||||
Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase.
|
||||
|
||||
=head2 dirmove()
|
||||
|
||||
Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase.
|
||||
|
||||
=head2 rmove()
|
||||
|
||||
Like rcopy() but calls fmove() or dirmove() instead.
|
||||
|
||||
=head2 rmove_glob()
|
||||
|
||||
Like rcopy_glob() but calls rmove() instead of rcopy()
|
||||
|
||||
=head3 $RemvBase
|
||||
|
||||
Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in.
|
||||
|
||||
So if you:
|
||||
|
||||
rmove('foo/bar/baz', '/etc/');
|
||||
# "baz" is removed from foo/bar after it is successfully copied to /etc/
|
||||
|
||||
local $File::Copy::Recursive::Remvbase = 1;
|
||||
rmove('foo/bar/baz','/etc/');
|
||||
# if baz is successfully copied to /etc/ :
|
||||
# first "baz" is removed from foo/bar
|
||||
# then "foo/bar is removed via pathrm()
|
||||
|
||||
=head4 $ForcePth
|
||||
|
||||
Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect.
|
||||
|
||||
=head2 Creating and Removing Paths
|
||||
|
||||
=head3 $NoFtlPth
|
||||
|
||||
Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure.
|
||||
|
||||
If its set to true they just silently go about their business regardless. This isn't a good idea but it's there if you want it.
|
||||
|
||||
=head3 $DirPerms
|
||||
|
||||
Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you.
|
||||
|
||||
Any value you set it to should be suitable for oct().
|
||||
|
||||
=head3 Path functions
|
||||
|
||||
These functions exist solely because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move functions work and use them by themselves if you wish.
|
||||
|
||||
=head4 pathrm()
|
||||
|
||||
Removes a given path recursively. It removes the *entire* path so be careful!!!
|
||||
|
||||
Returns 2 if the given path is not a directory.
|
||||
|
||||
File::Copy::Recursive::pathrm('foo/bar/baz') or die $!;
|
||||
# foo no longer exists
|
||||
|
||||
Same as:
|
||||
|
||||
rmdir 'foo/bar/baz' or die $!;
|
||||
rmdir 'foo/bar' or die $!;
|
||||
rmdir 'foo' or die $!;
|
||||
|
||||
An optional second argument makes it call pathempty() before any rmdir()'s when set to true.
|
||||
|
||||
File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!;
|
||||
# foo no longer exists
|
||||
|
||||
Same as:PFSCheck
|
||||
|
||||
File::Copy::Recursive::pathempty('foo/bar/baz') or die $!;
|
||||
rmdir 'foo/bar/baz' or die $!;
|
||||
File::Copy::Recursive::pathempty('foo/bar/') or die $!;
|
||||
rmdir 'foo/bar' or die $!;
|
||||
File::Copy::Recursive::pathempty('foo/') or die $!;
|
||||
rmdir 'foo' or die $!;
|
||||
|
||||
An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea.
|
||||
|
||||
=head4 pathempty()
|
||||
|
||||
Recursively removes the given directory's contents so it is empty. Returns 2 if the given argument is not a directory, 1 on successfully emptying the directory.
|
||||
|
||||
File::Copy::Recursive::pathempty($pth) or die $!;
|
||||
# $pth is now an empty directory
|
||||
|
||||
=head4 pathmk()
|
||||
|
||||
Creates a given path recursively. Creates foo/bar/baz even if foo does not exist.
|
||||
|
||||
File::Copy::Recursive::pathmk('foo/bar/baz') or die $!;
|
||||
|
||||
An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea.
|
||||
|
||||
=head4 pathrmdir()
|
||||
|
||||
Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents.
|
||||
Just removes the top directory the path given instead of the entire path like pathrm(). Returns 2 if the given argument does not exist (i.e. it's already gone). Returns false if it exists but is not a directory.
|
||||
|
||||
=head2 Preserving Mode
|
||||
|
||||
By default a quiet attempt is made to change the new file or directory to the mode of the old one.
|
||||
To turn this behavior off set
|
||||
$File::Copy::Recursive::KeepMode
|
||||
to false;
|
||||
|
||||
=head2 Managing Depth
|
||||
|
||||
You can set the maximum depth a directory structure is recursed by setting:
|
||||
$File::Copy::Recursive::MaxDepth
|
||||
to a whole number greater than 0.
|
||||
|
||||
=head2 SymLinks
|
||||
|
||||
If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file.
|
||||
Perl's symlink() is used instead of File::Copy's copy().
|
||||
You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value.
|
||||
It is already set to true or false depending on your system's support of symlinks so you can check it with an if statement to see how it will behave:
|
||||
|
||||
if($File::Copy::Recursive::CopyLink) {
|
||||
print "Symlinks will be preserved\n";
|
||||
} else {
|
||||
print "Symlinks will not be preserved because your system does not support it\n";
|
||||
}
|
||||
|
||||
If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. It's false by default.
|
||||
|
||||
local $File::Copy::Recursive::BdTrgWrn = 1;
|
||||
|
||||
=head2 Removing existing target file or directory before copying.
|
||||
|
||||
This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively.
|
||||
|
||||
0 = off (This is the default)
|
||||
|
||||
1 = carp() $! if removal fails
|
||||
|
||||
2 = return if removal fails
|
||||
|
||||
local $File::Copy::Recursive::RMTrgFil = 1;
|
||||
fcopy($orig, $target) or die $!;
|
||||
# if it fails it does warn() and keeps going
|
||||
|
||||
local $File::Copy::Recursive::RMTrgDir = 2;
|
||||
dircopy($orig, $target) or die $!;
|
||||
# if it fails it does your "or die"
|
||||
|
||||
This should be unnecessary most of the time but it's there if you need it :)
|
||||
|
||||
=head2 Turning off stat() check
|
||||
|
||||
By default the files or directories are checked to see if they are the same (i.e. linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info.
|
||||
It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System")
|
||||
|
||||
=head2 Emulating cp -rf dir1/ dir2/
|
||||
|
||||
By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not.
|
||||
|
||||
You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true.
|
||||
|
||||
NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists.
|
||||
If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above.
|
||||
|
||||
That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf.
|
||||
If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf).
|
||||
|
||||
So assuming 'foo/file':
|
||||
|
||||
dircopy('foo', 'bar') or die $!;
|
||||
# if bar does not exist the result is bar/file
|
||||
# if bar does exist the result is bar/file
|
||||
|
||||
$File::Copy::Recursive::CPRFComp = 1;
|
||||
dircopy('foo', 'bar') or die $!;
|
||||
# if bar does not exist the result is bar/file
|
||||
# if bar does exist the result is bar/foo/file
|
||||
|
||||
You can also specify a star for cp -rf glob type behavior:
|
||||
|
||||
dircopy('foo/*', 'bar') or die $!;
|
||||
# if bar does not exist the result is bar/file
|
||||
# if bar does exist the result is bar/file
|
||||
|
||||
$File::Copy::Recursive::CPRFComp = 1;
|
||||
dircopy('foo/*', 'bar') or die $!;
|
||||
# if bar does not exist the result is bar/file
|
||||
# if bar does exist the result is bar/file
|
||||
|
||||
NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (i.e. not like cp -rf fo* to copy foo/*).
|
||||
|
||||
=head2 Allowing Copy Loops
|
||||
|
||||
If you want to allow:
|
||||
|
||||
cp -rf . foo/
|
||||
|
||||
type behavior set $File::Copy::Recursive::CopyLoop to true.
|
||||
|
||||
This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem.
|
||||
|
||||
If you ever find a situation where $CopyLoop = 1 is desirable let me know. (i.e. it's a bad bad idea but is there if you want it)
|
||||
|
||||
(Note: On Windows this was necessary since it uses stat() to determine sameness and stat() is essentially useless for this on Windows.
|
||||
The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share)
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Copy> L<File::Spec>
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests.
|
||||
|
||||
Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive.
|
||||
|
||||
The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface.
|
||||
|
||||
I'll add this after the latest version has been out for a while with no new features or issues found :)
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Daniel Muey, L<http://drmuey.com/cpan_contact.pl>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2004 by Daniel Muey
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
817
database/perl/vendor/lib/File/Find/Rule.pm
vendored
Normal file
817
database/perl/vendor/lib/File/Find/Rule.pm
vendored
Normal file
@@ -0,0 +1,817 @@
|
||||
# $Id$
|
||||
|
||||
package File::Find::Rule;
|
||||
use strict;
|
||||
use File::Spec;
|
||||
use Text::Glob 'glob_to_regex';
|
||||
use Number::Compare;
|
||||
use Carp qw/croak/;
|
||||
use File::Find (); # we're only wrapping for now
|
||||
|
||||
our $VERSION = '0.34';
|
||||
|
||||
# we'd just inherit from Exporter, but I want the colon
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
my $to = caller;
|
||||
for my $sym ( qw( find rule ) ) {
|
||||
no strict 'refs';
|
||||
*{"$to\::$sym"} = \&{$sym};
|
||||
}
|
||||
for (grep /^:/, @_) {
|
||||
my ($extension) = /^:(.*)/;
|
||||
eval "require File::Find::Rule::$extension";
|
||||
croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@;
|
||||
}
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Find::Rule - Alternative interface to File::Find
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Find::Rule;
|
||||
# find all the subdirectories of a given directory
|
||||
my @subdirs = File::Find::Rule->directory->in( $directory );
|
||||
|
||||
# find all the .pm files in @INC
|
||||
my @files = File::Find::Rule->file()
|
||||
->name( '*.pm' )
|
||||
->in( @INC );
|
||||
|
||||
# as above, but without method chaining
|
||||
my $rule = File::Find::Rule->new;
|
||||
$rule->file;
|
||||
$rule->name( '*.pm' );
|
||||
my @files = $rule->in( @INC );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
File::Find::Rule is a friendlier interface to File::Find. It allows
|
||||
you to build rules which specify the desired files and directories.
|
||||
|
||||
=cut
|
||||
|
||||
# the procedural shim
|
||||
|
||||
*rule = \&find;
|
||||
sub find {
|
||||
my $object = __PACKAGE__->new();
|
||||
my $not = 0;
|
||||
|
||||
while (@_) {
|
||||
my $method = shift;
|
||||
my @args;
|
||||
|
||||
if ($method =~ s/^\!//) {
|
||||
# jinkies, we're really negating this
|
||||
unshift @_, $method;
|
||||
$not = 1;
|
||||
next;
|
||||
}
|
||||
unless (defined prototype $method) {
|
||||
my $args = shift;
|
||||
@args = ref $args eq 'ARRAY' ? @$args : $args;
|
||||
}
|
||||
if ($not) {
|
||||
$not = 0;
|
||||
@args = $object->new->$method(@args);
|
||||
$method = "not";
|
||||
}
|
||||
|
||||
my @return = $object->$method(@args);
|
||||
return @return if $method eq 'in';
|
||||
}
|
||||
$object;
|
||||
}
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item C<new>
|
||||
|
||||
A constructor. You need not invoke C<new> manually unless you wish
|
||||
to, as each of the rule-making methods will auto-create a suitable
|
||||
object if called as class methods.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $referent = shift;
|
||||
my $class = ref $referent || $referent;
|
||||
bless {
|
||||
rules => [],
|
||||
subs => {},
|
||||
iterator => [],
|
||||
extras => {},
|
||||
maxdepth => undef,
|
||||
mindepth => undef,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub _force_object {
|
||||
my $object = shift;
|
||||
$object = $object->new()
|
||||
unless ref $object;
|
||||
$object;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 Matching Rules
|
||||
|
||||
=over
|
||||
|
||||
=item C<name( @patterns )>
|
||||
|
||||
Specifies names that should match. May be globs or regular
|
||||
expressions.
|
||||
|
||||
$set->name( '*.mp3', '*.ogg' ); # mp3s or oggs
|
||||
$set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex
|
||||
$set->name( 'foo.bar' ); # just things named foo.bar
|
||||
|
||||
=cut
|
||||
|
||||
sub _flatten {
|
||||
my @flat;
|
||||
while (@_) {
|
||||
my $item = shift;
|
||||
ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item;
|
||||
}
|
||||
return @flat;
|
||||
}
|
||||
|
||||
sub name {
|
||||
my $self = _force_object shift;
|
||||
my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ );
|
||||
|
||||
push @{ $self->{rules} }, {
|
||||
rule => 'name',
|
||||
code => join( ' || ', map { "m{$_}" } @names ),
|
||||
args => \@_,
|
||||
};
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
=item -X tests
|
||||
|
||||
Synonyms are provided for each of the -X tests. See L<perlfunc/-X> for
|
||||
details. None of these methods take arguments.
|
||||
|
||||
Test | Method Test | Method
|
||||
------|------------- ------|----------------
|
||||
-r | readable -R | r_readable
|
||||
-w | writeable -W | r_writeable
|
||||
-w | writable -W | r_writable
|
||||
-x | executable -X | r_executable
|
||||
-o | owned -O | r_owned
|
||||
| |
|
||||
-e | exists -f | file
|
||||
-z | empty -d | directory
|
||||
-s | nonempty -l | symlink
|
||||
| -p | fifo
|
||||
-u | setuid -S | socket
|
||||
-g | setgid -b | block
|
||||
-k | sticky -c | character
|
||||
| -t | tty
|
||||
-M | modified |
|
||||
-A | accessed -T | ascii
|
||||
-C | changed -B | binary
|
||||
|
||||
Though some tests are fairly meaningless as binary flags (C<modified>,
|
||||
C<accessed>, C<changed>), they have been included for completeness.
|
||||
|
||||
# find nonempty files
|
||||
$rule->file,
|
||||
->nonempty;
|
||||
|
||||
=cut
|
||||
|
||||
use vars qw( %X_tests );
|
||||
%X_tests = (
|
||||
-r => readable => -R => r_readable =>
|
||||
-w => writeable => -W => r_writeable =>
|
||||
-w => writable => -W => r_writable =>
|
||||
-x => executable => -X => r_executable =>
|
||||
-o => owned => -O => r_owned =>
|
||||
|
||||
-e => exists => -f => file =>
|
||||
-z => empty => -d => directory =>
|
||||
-s => nonempty => -l => symlink =>
|
||||
=> -p => fifo =>
|
||||
-u => setuid => -S => socket =>
|
||||
-g => setgid => -b => block =>
|
||||
-k => sticky => -c => character =>
|
||||
=> -t => tty =>
|
||||
-M => modified =>
|
||||
-A => accessed => -T => ascii =>
|
||||
-C => changed => -B => binary =>
|
||||
);
|
||||
|
||||
for my $test (keys %X_tests) {
|
||||
my $sub = eval 'sub () {
|
||||
my $self = _force_object shift;
|
||||
push @{ $self->{rules} }, {
|
||||
code => "' . $test . ' \$_",
|
||||
rule => "'.$X_tests{$test}.'",
|
||||
};
|
||||
$self;
|
||||
} ';
|
||||
no strict 'refs';
|
||||
*{ $X_tests{$test} } = $sub;
|
||||
}
|
||||
|
||||
|
||||
=item stat tests
|
||||
|
||||
The following C<stat> based methods are provided: C<dev>, C<ino>,
|
||||
C<mode>, C<nlink>, C<uid>, C<gid>, C<rdev>, C<size>, C<atime>,
|
||||
C<mtime>, C<ctime>, C<blksize>, and C<blocks>. See L<perlfunc/stat>
|
||||
for details.
|
||||
|
||||
Each of these can take a number of targets, which will follow
|
||||
L<Number::Compare> semantics.
|
||||
|
||||
$rule->size( 7 ); # exactly 7
|
||||
$rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes
|
||||
$rule->size( ">=7" )
|
||||
->size( "<=90" ); # between 7 and 90, inclusive
|
||||
$rule->size( 7, 9, 42 ); # 7, 9 or 42
|
||||
|
||||
=cut
|
||||
|
||||
use vars qw( @stat_tests );
|
||||
@stat_tests = qw( dev ino mode nlink uid gid rdev
|
||||
size atime mtime ctime blksize blocks );
|
||||
{
|
||||
my $i = 0;
|
||||
for my $test (@stat_tests) {
|
||||
my $index = $i++; # to close over
|
||||
my $sub = sub {
|
||||
my $self = _force_object shift;
|
||||
|
||||
my @tests = map { Number::Compare->parse_to_perl($_) } @_;
|
||||
|
||||
push @{ $self->{rules} }, {
|
||||
rule => $test,
|
||||
args => \@_,
|
||||
code => 'do { my $val = (stat $_)['.$index.'] || 0;'.
|
||||
join ('||', map { "(\$val $_)" } @tests ).' }',
|
||||
};
|
||||
$self;
|
||||
};
|
||||
no strict 'refs';
|
||||
*$test = $sub;
|
||||
}
|
||||
}
|
||||
|
||||
=item C<any( @rules )>
|
||||
|
||||
=item C<or( @rules )>
|
||||
|
||||
Allows shortcircuiting boolean evaluation as an alternative to the
|
||||
default and-like nature of combined rules. C<any> and C<or> are
|
||||
interchangeable.
|
||||
|
||||
# find avis, movs, things over 200M and empty files
|
||||
$rule->any( File::Find::Rule->name( '*.avi', '*.mov' ),
|
||||
File::Find::Rule->size( '>200M' ),
|
||||
File::Find::Rule->file->empty,
|
||||
);
|
||||
|
||||
=cut
|
||||
|
||||
sub any {
|
||||
my $self = _force_object shift;
|
||||
# compile all the subrules to code fragments
|
||||
push @{ $self->{rules} }, {
|
||||
rule => "any",
|
||||
code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')',
|
||||
args => \@_,
|
||||
};
|
||||
|
||||
# merge all the subs hashes of the kids into ourself
|
||||
%{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_;
|
||||
$self;
|
||||
}
|
||||
|
||||
*or = \&any;
|
||||
|
||||
=item C<none( @rules )>
|
||||
|
||||
=item C<not( @rules )>
|
||||
|
||||
Negates a rule. (The inverse of C<any>.) C<none> and C<not> are
|
||||
interchangeable.
|
||||
|
||||
# files that aren't 8.3 safe
|
||||
$rule->file
|
||||
->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) );
|
||||
|
||||
=cut
|
||||
|
||||
sub not {
|
||||
my $self = _force_object shift;
|
||||
|
||||
push @{ $self->{rules} }, {
|
||||
rule => 'not',
|
||||
args => \@_,
|
||||
code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")",
|
||||
};
|
||||
|
||||
# merge all the subs hashes into us
|
||||
%{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_;
|
||||
$self;
|
||||
}
|
||||
|
||||
*none = \¬
|
||||
|
||||
=item C<prune>
|
||||
|
||||
Traverse no further. This rule always matches.
|
||||
|
||||
=cut
|
||||
|
||||
sub prune () {
|
||||
my $self = _force_object shift;
|
||||
|
||||
push @{ $self->{rules} },
|
||||
{
|
||||
rule => 'prune',
|
||||
code => '$File::Find::prune = 1'
|
||||
};
|
||||
$self;
|
||||
}
|
||||
|
||||
=item C<discard>
|
||||
|
||||
Don't keep this file. This rule always matches.
|
||||
|
||||
=cut
|
||||
|
||||
sub discard () {
|
||||
my $self = _force_object shift;
|
||||
|
||||
push @{ $self->{rules} }, {
|
||||
rule => 'discard',
|
||||
code => '$discarded = 1',
|
||||
};
|
||||
$self;
|
||||
}
|
||||
|
||||
=item C<exec( \&subroutine( $shortname, $path, $fullname ) )>
|
||||
|
||||
Allows user-defined rules. Your subroutine will be invoked with C<$_>
|
||||
set to the current short name, and with parameters of the name, the
|
||||
path you're in, and the full relative filename.
|
||||
|
||||
Return a true value if your rule matched.
|
||||
|
||||
# get things with long names
|
||||
$rules->exec( sub { length > 20 } );
|
||||
|
||||
=cut
|
||||
|
||||
sub exec {
|
||||
my $self = _force_object shift;
|
||||
my $code = shift;
|
||||
|
||||
push @{ $self->{rules} }, {
|
||||
rule => 'exec',
|
||||
code => $code,
|
||||
};
|
||||
$self;
|
||||
}
|
||||
|
||||
=item C<grep( @specifiers )>
|
||||
|
||||
Opens a file and tests it each line at a time.
|
||||
|
||||
For each line it evaluates each of the specifiers, stopping at the
|
||||
first successful match. A specifier may be a regular expression or a
|
||||
subroutine. The subroutine will be invoked with the same parameters
|
||||
as an ->exec subroutine.
|
||||
|
||||
It is possible to provide a set of negative specifiers by enclosing
|
||||
them in anonymous arrays. Should a negative specifier match the
|
||||
iteration is aborted and the clause is failed. For example:
|
||||
|
||||
$rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] );
|
||||
|
||||
Is a passing clause if the first line of a file looks like a perl
|
||||
shebang line.
|
||||
|
||||
=cut
|
||||
|
||||
sub grep {
|
||||
my $self = _force_object shift;
|
||||
my @pattern = map {
|
||||
ref $_
|
||||
? ref $_ eq 'ARRAY'
|
||||
? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_
|
||||
: [ $_ => 1 ]
|
||||
: [ qr/$_/ => 1 ]
|
||||
} @_;
|
||||
|
||||
$self->exec( sub {
|
||||
local *FILE;
|
||||
open FILE, $_ or return;
|
||||
local ($_, $.);
|
||||
while (<FILE>) {
|
||||
for my $p (@pattern) {
|
||||
my ($rule, $ret) = @$p;
|
||||
return $ret
|
||||
if ref $rule eq 'Regexp'
|
||||
? /$rule/
|
||||
: $rule->(@_);
|
||||
}
|
||||
}
|
||||
return;
|
||||
} );
|
||||
}
|
||||
|
||||
=item C<maxdepth( $level )>
|
||||
|
||||
Descend at most C<$level> (a non-negative integer) levels of directories
|
||||
below the starting point.
|
||||
|
||||
May be invoked many times per rule, but only the most recent value is
|
||||
used.
|
||||
|
||||
=item C<mindepth( $level )>
|
||||
|
||||
Do not apply any tests at levels less than C<$level> (a non-negative
|
||||
integer).
|
||||
|
||||
=item C<extras( \%extras )>
|
||||
|
||||
Specifies extra values to pass through to C<File::File::find> as part
|
||||
of the options hash.
|
||||
|
||||
For example this allows you to specify following of symlinks like so:
|
||||
|
||||
my $rule = File::Find::Rule->extras({ follow => 1 });
|
||||
|
||||
May be invoked many times per rule, but only the most recent value is
|
||||
used.
|
||||
|
||||
=cut
|
||||
|
||||
for my $setter (qw( maxdepth mindepth extras )) {
|
||||
my $sub = sub {
|
||||
my $self = _force_object shift;
|
||||
$self->{$setter} = shift;
|
||||
$self;
|
||||
};
|
||||
no strict 'refs';
|
||||
*$setter = $sub;
|
||||
}
|
||||
|
||||
|
||||
=item C<relative>
|
||||
|
||||
Trim the leading portion of any path found
|
||||
|
||||
=cut
|
||||
|
||||
sub relative () {
|
||||
my $self = _force_object shift;
|
||||
$self->{relative} = 1;
|
||||
$self;
|
||||
}
|
||||
|
||||
=item C<canonpath>
|
||||
|
||||
Normalize paths found using C<File::Spec->canonpath>. This will return paths
|
||||
with a file-seperator that is native to your OS (as determined by L<File::Spec>),
|
||||
instead of the default C</>.
|
||||
|
||||
For example, this will return C<tmp/foobar> on Unix-ish OSes
|
||||
and C<tmp\foobar> on Win32.
|
||||
|
||||
=cut
|
||||
|
||||
sub canonpath () {
|
||||
my $self = _force_object shift;
|
||||
$self->{canonpath} = 1;
|
||||
$self;
|
||||
}
|
||||
|
||||
=item C<not_*>
|
||||
|
||||
Negated version of the rule. An effective shortand related to ! in
|
||||
the procedural interface.
|
||||
|
||||
$foo->not_name('*.pl');
|
||||
|
||||
$foo->not( $foo->new->name('*.pl' ) );
|
||||
|
||||
=cut
|
||||
|
||||
sub DESTROY {}
|
||||
sub AUTOLOAD {
|
||||
our $AUTOLOAD;
|
||||
$AUTOLOAD =~ /::not_([^:]*)$/
|
||||
or croak "Can't locate method $AUTOLOAD";
|
||||
my $method = $1;
|
||||
|
||||
my $sub = sub {
|
||||
my $self = _force_object shift;
|
||||
$self->not( $self->new->$method(@_) );
|
||||
};
|
||||
{
|
||||
no strict 'refs';
|
||||
*$AUTOLOAD = $sub;
|
||||
}
|
||||
&$sub;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 Query Methods
|
||||
|
||||
=over
|
||||
|
||||
=item C<in( @directories )>
|
||||
|
||||
Evaluates the rule, returns a list of paths to matching files and
|
||||
directories.
|
||||
|
||||
=cut
|
||||
|
||||
sub in {
|
||||
my $self = _force_object shift;
|
||||
|
||||
my @found;
|
||||
my $fragment = $self->_compile;
|
||||
my %subs = %{ $self->{subs} };
|
||||
|
||||
warn "relative mode handed multiple paths - that's a bit silly\n"
|
||||
if $self->{relative} && @_ > 1;
|
||||
|
||||
my $topdir;
|
||||
my $code = 'sub {
|
||||
(my $path = $File::Find::name) =~ s#^(?:\./+)+##;
|
||||
my @args = ($_, $File::Find::dir, $path);
|
||||
my $maxdepth = $self->{maxdepth};
|
||||
my $mindepth = $self->{mindepth};
|
||||
my $relative = $self->{relative};
|
||||
my $canonpath = $self->{canonpath};
|
||||
|
||||
# figure out the relative path and depth
|
||||
my $relpath = $File::Find::name;
|
||||
$relpath =~ s{^\Q$topdir\E/?}{};
|
||||
my $depth = scalar File::Spec->splitdir($relpath);
|
||||
#print "name: \'$File::Find::name\' ";
|
||||
#print "relpath: \'$relpath\' depth: $depth relative: $relative\n";
|
||||
|
||||
defined $maxdepth && $depth >= $maxdepth
|
||||
and $File::Find::prune = 1;
|
||||
|
||||
defined $mindepth && $depth < $mindepth
|
||||
and return;
|
||||
|
||||
#print "Testing \'$_\'\n";
|
||||
|
||||
my $discarded;
|
||||
return unless ' . $fragment . ';
|
||||
return if $discarded;
|
||||
if ($relative) {
|
||||
if ($relpath ne "") {
|
||||
push @found, $canonpath ? File::Spec->canonpath($relpath) : $relpath;
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @found, $canonpath ? File::Spec->canonpath($path) : $path;
|
||||
}
|
||||
}';
|
||||
|
||||
#use Data::Dumper;
|
||||
#print Dumper \%subs;
|
||||
#warn "Compiled sub: '$code'\n";
|
||||
|
||||
my $sub = eval "$code" or die "compile error '$code' $@";
|
||||
for my $path (@_) {
|
||||
# $topdir is used for relative and maxdepth
|
||||
$topdir = $path;
|
||||
# slice off the trailing slash if there is one (the
|
||||
# maxdepth/mindepth code is fussy)
|
||||
$topdir =~ s{/?$}{}
|
||||
unless $topdir eq '/';
|
||||
$self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path );
|
||||
}
|
||||
|
||||
return @found;
|
||||
}
|
||||
|
||||
sub _call_find {
|
||||
my $self = shift;
|
||||
File::Find::find( @_ );
|
||||
}
|
||||
|
||||
sub _compile {
|
||||
my $self = shift;
|
||||
|
||||
return '1' unless @{ $self->{rules} };
|
||||
my $code = join " && ", map {
|
||||
if (ref $_->{code}) {
|
||||
my $key = "$_->{code}";
|
||||
$self->{subs}{$key} = $_->{code};
|
||||
"\$subs{'$key'}->(\@args) # $_->{rule}\n";
|
||||
}
|
||||
else {
|
||||
"( $_->{code} ) # $_->{rule}\n";
|
||||
}
|
||||
} @{ $self->{rules} };
|
||||
|
||||
#warn $code;
|
||||
return $code;
|
||||
}
|
||||
|
||||
=item C<start( @directories )>
|
||||
|
||||
Starts a find across the specified directories. Matching items may
|
||||
then be queried using L</match>. This allows you to use a rule as an
|
||||
iterator.
|
||||
|
||||
my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" );
|
||||
while ( defined ( my $image = $rule->match ) ) {
|
||||
...
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub start {
|
||||
my $self = _force_object shift;
|
||||
|
||||
$self->{iterator} = [ $self->in( @_ ) ];
|
||||
$self;
|
||||
}
|
||||
|
||||
=item C<match>
|
||||
|
||||
Returns the next file which matches, false if there are no more.
|
||||
|
||||
=cut
|
||||
|
||||
sub match {
|
||||
my $self = _force_object shift;
|
||||
|
||||
return shift @{ $self->{iterator} };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=back
|
||||
|
||||
=head2 Extensions
|
||||
|
||||
Extension modules are available from CPAN in the File::Find::Rule
|
||||
namespace. In order to use these extensions either use them directly:
|
||||
|
||||
use File::Find::Rule::ImageSize;
|
||||
use File::Find::Rule::MMagic;
|
||||
|
||||
# now your rules can use the clauses supplied by the ImageSize and
|
||||
# MMagic extension
|
||||
|
||||
or, specify that File::Find::Rule should load them for you:
|
||||
|
||||
use File::Find::Rule qw( :ImageSize :MMagic );
|
||||
|
||||
For notes on implementing your own extensions, consult
|
||||
L<File::Find::Rule::Extending>
|
||||
|
||||
=head2 Further examples
|
||||
|
||||
=over
|
||||
|
||||
=item Finding perl scripts
|
||||
|
||||
my $finder = File::Find::Rule->or
|
||||
(
|
||||
File::Find::Rule->name( '*.pl' ),
|
||||
File::Find::Rule->exec(
|
||||
sub {
|
||||
if (open my $fh, $_) {
|
||||
my $shebang = <$fh>;
|
||||
close $fh;
|
||||
return $shebang =~ /^#!.*\bperl/;
|
||||
}
|
||||
return 0;
|
||||
} ),
|
||||
);
|
||||
|
||||
Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842
|
||||
|
||||
=item ignore CVS directories
|
||||
|
||||
my $rule = File::Find::Rule->new;
|
||||
$rule->or($rule->new
|
||||
->directory
|
||||
->name('CVS')
|
||||
->prune
|
||||
->discard,
|
||||
$rule->new);
|
||||
|
||||
Note here the use of a null rule. Null rules match anything they see,
|
||||
so the effect is to match (and discard) directories called 'CVS' or to
|
||||
match anything.
|
||||
|
||||
=back
|
||||
|
||||
=head1 TWO FOR THE PRICE OF ONE
|
||||
|
||||
File::Find::Rule also gives you a procedural interface. This is
|
||||
documented in L<File::Find::Rule::Procedural>
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
L</find>, L</rule>
|
||||
|
||||
=head1 TAINT MODE INTERACTION
|
||||
|
||||
As of 0.32 File::Find::Rule doesn't capture the current working directory in
|
||||
a taint-unsafe manner. File::Find itself still does operations that the taint
|
||||
system will flag as insecure but you can use the L</extras> feature to ask
|
||||
L<File::Find> to internally C<untaint> file paths with a regex like so:
|
||||
|
||||
my $rule = File::Find::Rule->extras({ untaint => 1 });
|
||||
|
||||
Please consult L<File::Find>'s documentation for C<untaint>,
|
||||
C<untaint_pattern>, and C<untaint_skip> for more information.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
The code makes use of the C<our> keyword and as such requires perl version
|
||||
5.6.0 or newer.
|
||||
|
||||
Currently it isn't possible to remove a clause from a rule object. If
|
||||
this becomes a significant issue it will be addressed.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Richard Clamp <richardc@unixbeard.net> with input gained from this
|
||||
use.perl discussion: http://use.perl.org/~richardc/journal/6467
|
||||
|
||||
Additional proofreading and input provided by Kake, Greg McCarroll,
|
||||
and Andy Lester andy@petdance.com.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 2002, 2003, 2004, 2006, 2009, 2011 Richard Clamp. All Rights Reserved.
|
||||
|
||||
This module is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Find>, L<Text::Glob>, L<Number::Compare>, find(1)
|
||||
|
||||
If you want to know about the procedural interface, see
|
||||
L<File::Find::Rule::Procedural>, and if you have an idea for a neat
|
||||
extension L<File::Find::Rule::Extending>
|
||||
|
||||
=cut
|
||||
|
||||
Implementation notes:
|
||||
|
||||
$self->rules is an array of hashrefs. it may be a code fragment or a call
|
||||
to a subroutine.
|
||||
|
||||
Anonymous subroutines are stored in the $self->subs hashref keyed on the
|
||||
stringfied version of the coderef.
|
||||
|
||||
When one File::Find::Rule object is combined with another, such as in the any
|
||||
and not operations, this entire hash is merged.
|
||||
|
||||
The _compile method walks the rules element and simply glues the code
|
||||
fragments together so they can be compiled into an anyonymous File::Find
|
||||
match sub for speed
|
||||
|
||||
|
||||
[*] There's probably a win to be made with the current model in making
|
||||
stat calls use C<_>. For
|
||||
|
||||
find( file => size => "> 20M" => size => "< 400M" );
|
||||
|
||||
up to 3 stats will happen for each candidate. Adding a priming _
|
||||
would be a bit blind if the first operation was C< name => 'foo' >,
|
||||
since that can be tested by a single regex. Simply checking what the
|
||||
next type of operation doesn't work since any arbritary exec sub may
|
||||
or may not stat. Potentially worse, they could stat something else
|
||||
like so:
|
||||
|
||||
# extract from the worlds stupidest make(1)
|
||||
find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } );
|
||||
|
||||
Maybe the best way is to treat C<_> as invalid after calling an exec,
|
||||
and doc that C<_> will only be meaningful after stat and -X tests if
|
||||
they're wanted in exec blocks.
|
||||
91
database/perl/vendor/lib/File/Find/Rule/Extending.pod
vendored
Normal file
91
database/perl/vendor/lib/File/Find/Rule/Extending.pod
vendored
Normal file
@@ -0,0 +1,91 @@
|
||||
=head1 NAME
|
||||
|
||||
File::Find::Rule::Extending - the mini-guide to extending File::Find::Rule
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package File::Find::Rule::Random;
|
||||
use strict;
|
||||
|
||||
# take useful things from File::Find::Rule
|
||||
use base 'File::Find::Rule';
|
||||
|
||||
# and force our crack into the main namespace
|
||||
sub File::Find::Rule::random () {
|
||||
my $self = shift()->_force_object;
|
||||
$self->exec( sub { rand > 0.5 } );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
File::Find::Rule went down so well with the buying public that
|
||||
everyone wanted to add extra features. With the 0.07 release this
|
||||
became a possibility, using the following conventions.
|
||||
|
||||
=head2 Declare your package
|
||||
|
||||
package File::Find::Rule::Random;
|
||||
use strict;
|
||||
|
||||
=head2 Inherit methods from File::Find::Rule
|
||||
|
||||
# take useful things from File::Find::Rule
|
||||
use base 'File::Find::Rule';
|
||||
|
||||
=head3 Force your madness into the main package
|
||||
|
||||
# and force our crack into the main namespace
|
||||
sub File::Find::Rule::random () {
|
||||
my $self = shift()->_force_object;
|
||||
$self->exec( sub { rand > 0.5 } );
|
||||
}
|
||||
|
||||
|
||||
Yes, we're being very cavalier here and defining things into the main
|
||||
File::Find::Rule namespace. This is due to lack of imaginiation on my
|
||||
part - I simply can't find a way for the functional and oo interface
|
||||
to work without doing this or some kind of inheritance, and
|
||||
inheritance stops you using two File::Find::Rule::Foo modules
|
||||
together.
|
||||
|
||||
For this reason try and pick distinct names for your extensions. If
|
||||
this becomes a problem then I may institute a semi-official registry
|
||||
of taken names.
|
||||
|
||||
=head2 Taking no arguments.
|
||||
|
||||
Note the null prototype on random. This is a cheat for the procedural
|
||||
interface to know that your sub takes no arguments, and so allows this
|
||||
to happen:
|
||||
|
||||
find( random => in => '.' );
|
||||
|
||||
If you hadn't declared C<random> with a null prototype it would have
|
||||
consumed C<in> as a parameter to it, then got all confused as it
|
||||
doesn't know about a C<'.'> rule.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Richard Clamp <richardc@unixbeard.net>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 2002 Richard Clamp. All Rights Reserved.
|
||||
|
||||
This module is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Find::Rule>
|
||||
|
||||
L<File::Find::Rule::MMagic> was the first extension module, so maybe
|
||||
check that out.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
|
||||
72
database/perl/vendor/lib/File/Find/Rule/Procedural.pod
vendored
Normal file
72
database/perl/vendor/lib/File/Find/Rule/Procedural.pod
vendored
Normal file
@@ -0,0 +1,72 @@
|
||||
=head1 NAME
|
||||
|
||||
File::Find::Rule::Procedural - File::Find::Rule's procedural interface
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Find::Rule;
|
||||
|
||||
# find all .pm files, procedurally
|
||||
my @files = find(file => name => '*.pm', in => \@INC);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
In addition to the regular object-oriented interface,
|
||||
L<File::Find::Rule> provides two subroutines for you to use.
|
||||
|
||||
=over
|
||||
|
||||
=item C<find( @clauses )>
|
||||
|
||||
=item C<rule( @clauses )>
|
||||
|
||||
C<find> and C<rule> can be used to invoke any methods available to the
|
||||
OO version. C<rule> is a synonym for C<find>
|
||||
|
||||
=back
|
||||
|
||||
Passing more than one value to a clause is done with an anonymous
|
||||
array:
|
||||
|
||||
my $finder = find( name => [ '*.mp3', '*.ogg' ] );
|
||||
|
||||
C<find> and C<rule> both return a File::Find::Rule instance, unless
|
||||
one of the arguments is C<in>, in which case it returns a list of
|
||||
things that match the rule.
|
||||
|
||||
my @files = find( name => [ '*.mp3', '*.ogg' ], in => $ENV{HOME} );
|
||||
|
||||
Please note that C<in> will be the last clause evaluated, and so this
|
||||
code will search for mp3s regardless of size.
|
||||
|
||||
my @files = find( name => '*.mp3', in => $ENV{HOME}, size => '<2k' );
|
||||
^
|
||||
|
|
||||
Clause processing stopped here ------/
|
||||
|
||||
It is also possible to invert a single rule by prefixing it with C<!>
|
||||
like so:
|
||||
|
||||
# large files that aren't videos
|
||||
my @files = find( file =>
|
||||
'!name' => [ '*.avi', '*.mov' ],
|
||||
size => '>20M',
|
||||
in => $ENV{HOME} );
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Richard Clamp <richardc@unixbeard.net>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 2003 Richard Clamp. All Rights Reserved.
|
||||
|
||||
This module is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Find::Rule>
|
||||
|
||||
=cut
|
||||
728
database/perl/vendor/lib/File/HomeDir.pm
vendored
Normal file
728
database/perl/vendor/lib/File/HomeDir.pm
vendored
Normal file
@@ -0,0 +1,728 @@
|
||||
package File::HomeDir;
|
||||
|
||||
# See POD at end for documentation
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use Config ();
|
||||
use File::Spec ();
|
||||
use File::Which ();
|
||||
|
||||
# Globals
|
||||
use vars qw{$VERSION @EXPORT @EXPORT_OK $IMPLEMENTED_BY}; ## no critic qw(AutomaticExportation)
|
||||
use base qw(Exporter);
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
|
||||
# Inherit manually
|
||||
require Exporter;
|
||||
@EXPORT = qw{home};
|
||||
@EXPORT_OK = qw{
|
||||
home
|
||||
my_home
|
||||
my_desktop
|
||||
my_documents
|
||||
my_music
|
||||
my_pictures
|
||||
my_videos
|
||||
my_data
|
||||
my_dist_config
|
||||
my_dist_data
|
||||
users_home
|
||||
users_desktop
|
||||
users_documents
|
||||
users_music
|
||||
users_pictures
|
||||
users_videos
|
||||
users_data
|
||||
};
|
||||
}
|
||||
|
||||
# Inlined Params::Util functions
|
||||
sub _CLASS ($) ## no critic qw(SubroutinePrototypes)
|
||||
{
|
||||
(defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _DRIVER ($$) ## no critic qw(SubroutinePrototypes)
|
||||
{
|
||||
(defined _CLASS($_[0]) and eval "require $_[0]; 1" and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
# Platform detection
|
||||
if ($IMPLEMENTED_BY)
|
||||
{
|
||||
# Allow for custom HomeDir classes
|
||||
# Leave it as the existing value
|
||||
}
|
||||
elsif ($^O eq 'MSWin32')
|
||||
{
|
||||
# All versions of Windows
|
||||
$IMPLEMENTED_BY = 'File::HomeDir::Windows';
|
||||
}
|
||||
elsif ($^O eq 'darwin')
|
||||
{
|
||||
# 1st: try Mac::SystemDirectory by chansen
|
||||
if (eval "require Mac::SystemDirectory; 1")
|
||||
{
|
||||
$IMPLEMENTED_BY = 'File::HomeDir::Darwin::Cocoa';
|
||||
}
|
||||
elsif (eval "require Mac::Files; 1")
|
||||
{
|
||||
# 2nd try Mac::Files: Carbon - unmaintained since 2006 except some 64bit fixes
|
||||
$IMPLEMENTED_BY = 'File::HomeDir::Darwin::Carbon';
|
||||
}
|
||||
else
|
||||
{
|
||||
# 3rd: fallback: pure perl
|
||||
$IMPLEMENTED_BY = 'File::HomeDir::Darwin';
|
||||
}
|
||||
}
|
||||
elsif ($^O eq 'MacOS')
|
||||
{
|
||||
# Legacy Mac OS
|
||||
$IMPLEMENTED_BY = 'File::HomeDir::MacOS9';
|
||||
}
|
||||
elsif (File::Which::which('xdg-user-dir'))
|
||||
{
|
||||
# freedesktop unixes
|
||||
$IMPLEMENTED_BY = 'File::HomeDir::FreeDesktop';
|
||||
}
|
||||
else
|
||||
{
|
||||
# Default to Unix semantics
|
||||
$IMPLEMENTED_BY = 'File::HomeDir::Unix';
|
||||
}
|
||||
|
||||
unless (_DRIVER($IMPLEMENTED_BY, 'File::HomeDir::Driver'))
|
||||
{
|
||||
Carp::croak("Missing or invalid File::HomeDir driver $IMPLEMENTED_BY");
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
sub my_home
|
||||
{
|
||||
$IMPLEMENTED_BY->my_home;
|
||||
}
|
||||
|
||||
sub my_desktop
|
||||
{
|
||||
$IMPLEMENTED_BY->can('my_desktop')
|
||||
? $IMPLEMENTED_BY->my_desktop
|
||||
: Carp::croak("The my_desktop method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub my_documents
|
||||
{
|
||||
$IMPLEMENTED_BY->can('my_documents')
|
||||
? $IMPLEMENTED_BY->my_documents
|
||||
: Carp::croak("The my_documents method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub my_music
|
||||
{
|
||||
$IMPLEMENTED_BY->can('my_music')
|
||||
? $IMPLEMENTED_BY->my_music
|
||||
: Carp::croak("The my_music method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub my_pictures
|
||||
{
|
||||
$IMPLEMENTED_BY->can('my_pictures')
|
||||
? $IMPLEMENTED_BY->my_pictures
|
||||
: Carp::croak("The my_pictures method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub my_videos
|
||||
{
|
||||
$IMPLEMENTED_BY->can('my_videos')
|
||||
? $IMPLEMENTED_BY->my_videos
|
||||
: Carp::croak("The my_videos method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub my_data
|
||||
{
|
||||
$IMPLEMENTED_BY->can('my_data')
|
||||
? $IMPLEMENTED_BY->my_data
|
||||
: Carp::croak("The my_data method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub my_dist_data
|
||||
{
|
||||
my $params = ref $_[-1] eq 'HASH' ? pop : {};
|
||||
my $dist = pop or Carp::croak("The my_dist_data method requires an argument");
|
||||
my $data = my_data();
|
||||
|
||||
# If datadir is not defined, there's nothing we can do: bail out
|
||||
# and return nothing...
|
||||
return undef unless defined $data;
|
||||
|
||||
# On traditional unixes, hide the top-level directory
|
||||
my $var =
|
||||
$data eq home()
|
||||
? File::Spec->catdir($data, '.perl', 'dist', $dist)
|
||||
: File::Spec->catdir($data, 'Perl', 'dist', $dist);
|
||||
|
||||
# directory exists: return it
|
||||
return $var if -d $var;
|
||||
|
||||
# directory doesn't exist: check if we need to create it...
|
||||
return undef unless $params->{create};
|
||||
|
||||
# user requested directory creation
|
||||
require File::Path;
|
||||
File::Path::mkpath($var);
|
||||
return $var;
|
||||
}
|
||||
|
||||
sub my_dist_config
|
||||
{
|
||||
my $params = ref $_[-1] eq 'HASH' ? pop : {};
|
||||
my $dist = pop or Carp::croak("The my_dist_config method requires an argument");
|
||||
|
||||
# not all platforms support a specific my_config() method
|
||||
my $config =
|
||||
$IMPLEMENTED_BY->can('my_config')
|
||||
? $IMPLEMENTED_BY->my_config
|
||||
: $IMPLEMENTED_BY->my_documents;
|
||||
|
||||
# If neither configdir nor my_documents is defined, there's
|
||||
# nothing we can do: bail out and return nothing...
|
||||
return undef unless defined $config;
|
||||
|
||||
# On traditional unixes, hide the top-level dir
|
||||
my $etc =
|
||||
$config eq home()
|
||||
? File::Spec->catdir($config, '.perl', $dist)
|
||||
: File::Spec->catdir($config, 'Perl', $dist);
|
||||
|
||||
# directory exists: return it
|
||||
return $etc if -d $etc;
|
||||
|
||||
# directory doesn't exist: check if we need to create it...
|
||||
return undef unless $params->{create};
|
||||
|
||||
# user requested directory creation
|
||||
require File::Path;
|
||||
File::Path::mkpath($etc);
|
||||
return $etc;
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# General User Methods
|
||||
|
||||
sub users_home
|
||||
{
|
||||
$IMPLEMENTED_BY->can('users_home')
|
||||
? $IMPLEMENTED_BY->users_home($_[-1])
|
||||
: Carp::croak("The users_home method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub users_desktop
|
||||
{
|
||||
$IMPLEMENTED_BY->can('users_desktop')
|
||||
? $IMPLEMENTED_BY->users_desktop($_[-1])
|
||||
: Carp::croak("The users_desktop method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub users_documents
|
||||
{
|
||||
$IMPLEMENTED_BY->can('users_documents')
|
||||
? $IMPLEMENTED_BY->users_documents($_[-1])
|
||||
: Carp::croak("The users_documents method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub users_music
|
||||
{
|
||||
$IMPLEMENTED_BY->can('users_music')
|
||||
? $IMPLEMENTED_BY->users_music($_[-1])
|
||||
: Carp::croak("The users_music method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub users_pictures
|
||||
{
|
||||
$IMPLEMENTED_BY->can('users_pictures')
|
||||
? $IMPLEMENTED_BY->users_pictures($_[-1])
|
||||
: Carp::croak("The users_pictures method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub users_videos
|
||||
{
|
||||
$IMPLEMENTED_BY->can('users_videos')
|
||||
? $IMPLEMENTED_BY->users_videos($_[-1])
|
||||
: Carp::croak("The users_videos method is not implemented on this platform");
|
||||
}
|
||||
|
||||
sub users_data
|
||||
{
|
||||
$IMPLEMENTED_BY->can('users_data')
|
||||
? $IMPLEMENTED_BY->users_data($_[-1])
|
||||
: Carp::croak("The users_data method is not implemented on this platform");
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Legacy Methods
|
||||
|
||||
# Find the home directory of an arbitrary user
|
||||
sub home (;$) ## no critic qw(SubroutinePrototypes)
|
||||
{
|
||||
# Allow to be called as a method
|
||||
if ($_[0] and $_[0] eq 'File::HomeDir')
|
||||
{
|
||||
shift();
|
||||
}
|
||||
|
||||
# No params means my home
|
||||
return my_home() unless @_;
|
||||
|
||||
# Check the param
|
||||
my $name = shift;
|
||||
if (!defined $name)
|
||||
{
|
||||
Carp::croak("Can't use undef as a username");
|
||||
}
|
||||
if (!length $name)
|
||||
{
|
||||
Carp::croak("Can't use empty-string (\"\") as a username");
|
||||
}
|
||||
|
||||
# A dot also means my home
|
||||
### Is this meant to mean File::Spec->curdir?
|
||||
if ($name eq '.')
|
||||
{
|
||||
return my_home();
|
||||
}
|
||||
|
||||
# Now hand off to the implementor
|
||||
$IMPLEMENTED_BY->users_home($name);
|
||||
}
|
||||
eval {
|
||||
require Portable;
|
||||
Portable->import('HomeDir');
|
||||
};
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir - Find your home and other directories on any platform
|
||||
|
||||
=begin html
|
||||
|
||||
<a href="https://travis-ci.org/perl5-utils/File-HomeDir"><img src="https://travis-ci.org/perl5-utils/File-HomeDir.svg?branch=master" alt="Travis CI"/></a>
|
||||
<a href='https://coveralls.io/github/perl5-utils/File-HomeDir?branch=master'><img src='https://coveralls.io/repos/github/perl5-utils/File-HomeDir/badge.svg?branch=master' alt='Coverage Status'/></a>
|
||||
|
||||
=end html
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Modern Interface (Current User)
|
||||
$home = File::HomeDir->my_home;
|
||||
$desktop = File::HomeDir->my_desktop;
|
||||
$docs = File::HomeDir->my_documents;
|
||||
$music = File::HomeDir->my_music;
|
||||
$pics = File::HomeDir->my_pictures;
|
||||
$videos = File::HomeDir->my_videos;
|
||||
$data = File::HomeDir->my_data;
|
||||
$dist = File::HomeDir->my_dist_data('File-HomeDir');
|
||||
$dist = File::HomeDir->my_dist_config('File-HomeDir');
|
||||
|
||||
# Modern Interface (Other Users)
|
||||
$home = File::HomeDir->users_home('foo');
|
||||
$desktop = File::HomeDir->users_desktop('foo');
|
||||
$docs = File::HomeDir->users_documents('foo');
|
||||
$music = File::HomeDir->users_music('foo');
|
||||
$pics = File::HomeDir->users_pictures('foo');
|
||||
$video = File::HomeDir->users_videos('foo');
|
||||
$data = File::HomeDir->users_data('foo');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<File::HomeDir> is a module for locating the directories that are "owned"
|
||||
by a user (typically your user) and to solve the various issues that arise
|
||||
trying to find them consistently across a wide variety of platforms.
|
||||
|
||||
The end result is a single API that can find your resources on any platform,
|
||||
making it relatively trivial to create Perl software that works elegantly
|
||||
and correctly no matter where you run it.
|
||||
|
||||
=head2 Platform Neutrality
|
||||
|
||||
In the Unix world, many different types of data can be mixed together
|
||||
in your home directory (although on some Unix platforms this is no longer
|
||||
the case, particularly for "desktop"-oriented platforms).
|
||||
|
||||
On some non-Unix platforms, separate directories are allocated for
|
||||
different types of data and have been for a long time.
|
||||
|
||||
When writing applications on top of B<File::HomeDir>, you should thus
|
||||
always try to use the most specific method you can. User documents should
|
||||
be saved in C<my_documents>, data that supports an application but isn't
|
||||
normally editing by the user directory should go into C<my_data>.
|
||||
|
||||
On platforms that do not make any distinction, all these different
|
||||
methods will harmlessly degrade to the main home directory, but on
|
||||
platforms that care B<File::HomeDir> will always try to Do The Right
|
||||
Thing(tm).
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
Two types of methods are provided. The C<my_method> series of methods for
|
||||
finding resources for the current user, and the C<users_method> (read as
|
||||
"user's method") series for finding resources for arbitrary users.
|
||||
|
||||
This split is necessary, as on most platforms it is B<much> easier to find
|
||||
information about the current user compared to other users, and indeed
|
||||
on a number you cannot find out information such as C<users_desktop> at
|
||||
all, due to security restrictions.
|
||||
|
||||
All methods will double check (using a C<-d> test) that a directory
|
||||
actually exists before returning it, so you may trust in the values
|
||||
that are returned (subject to the usual caveats of race conditions of
|
||||
directories being deleted at the moment between a directory being returned
|
||||
and you using it).
|
||||
|
||||
However, because in some cases platforms may not support the concept of home
|
||||
directories at all, any method may return C<undef> (both in scalar and list
|
||||
context) to indicate that there is no matching directory on the system.
|
||||
|
||||
For example, most untrusted 'nobody'-type users do not have a home
|
||||
directory. So any modules that are used in a CGI application that
|
||||
at some level of recursion use your code, will result in calls to
|
||||
File::HomeDir returning undef, even for a basic home() call.
|
||||
|
||||
=head2 my_home
|
||||
|
||||
The C<my_home> method takes no arguments and returns the main home/profile
|
||||
directory for the current user.
|
||||
|
||||
If the distinction is important to you, the term "current" refers to the
|
||||
real user, and not the effective user.
|
||||
|
||||
This is also the case for all of the other "my" methods.
|
||||
|
||||
Returns the directory path as a string, C<undef> if the current user
|
||||
does not have a home directory, or dies on error.
|
||||
|
||||
=head2 my_desktop
|
||||
|
||||
The C<my_desktop> method takes no arguments and returns the "desktop"
|
||||
directory for the current user.
|
||||
|
||||
Due to the diversity and complexity of implementations required to deal with
|
||||
implementing the required functionality fully and completely, the
|
||||
C<my_desktop> method may or may not be implemented on each platform.
|
||||
|
||||
That said, I am extremely interested in code to implement C<my_desktop> on
|
||||
Unix, as long as it is capable of dealing (as the Windows implementation
|
||||
does) with internationalization. It should also avoid false positive
|
||||
results by making sure it only returns the appropriate directories for the
|
||||
appropriate platforms.
|
||||
|
||||
Returns the directory path as a string, C<undef> if the current user
|
||||
does not have a desktop directory, or dies on error.
|
||||
|
||||
=head2 my_documents
|
||||
|
||||
The C<my_documents> method takes no arguments and returns the directory (for
|
||||
the current user) where the user's documents are stored.
|
||||
|
||||
Returns the directory path as a string, C<undef> if the current user
|
||||
does not have a documents directory, or dies on error.
|
||||
|
||||
=head2 my_music
|
||||
|
||||
The C<my_music> method takes no arguments and returns the directory
|
||||
where the current user's music is stored.
|
||||
|
||||
No bias is made to any particular music type or music program, rather the
|
||||
concept of a directory to hold the user's music is made at the level of the
|
||||
underlying operating system or (at least) desktop environment.
|
||||
|
||||
Returns the directory path as a string, C<undef> if the current user
|
||||
does not have a suitable directory, or dies on error.
|
||||
|
||||
=head2 my_pictures
|
||||
|
||||
The C<my_pictures> method takes no arguments and returns the directory
|
||||
where the current user's pictures are stored.
|
||||
|
||||
No bias is made to any particular picture type or picture program, rather the
|
||||
concept of a directory to hold the user's pictures is made at the level of the
|
||||
underlying operating system or (at least) desktop environment.
|
||||
|
||||
Returns the directory path as a string, C<undef> if the current user
|
||||
does not have a suitable directory, or dies on error.
|
||||
|
||||
=head2 my_videos
|
||||
|
||||
The C<my_videos> method takes no arguments and returns the directory
|
||||
where the current user's videos are stored.
|
||||
|
||||
No bias is made to any particular video type or video program, rather the
|
||||
concept of a directory to hold the user's videos is made at the level of the
|
||||
underlying operating system or (at least) desktop environment.
|
||||
|
||||
Returns the directory path as a string, C<undef> if the current user
|
||||
does not have a suitable directory, or dies on error.
|
||||
|
||||
=head2 my_data
|
||||
|
||||
The C<my_data> method takes no arguments and returns the directory where
|
||||
local applications should store their internal data for the current
|
||||
user.
|
||||
|
||||
Generally an application would create a subdirectory such as C<.foo>,
|
||||
beneath this directory, and store its data there. By creating your
|
||||
directory this way, you get an accurate result on the maximum number of
|
||||
platforms. But see the documentation about C<my_dist_config()> or
|
||||
C<my_dist_data()> below.
|
||||
|
||||
For example, on Unix you get C<~/.foo> and on Win32 you get
|
||||
C<~/Local Settings/Application Data/.foo>
|
||||
|
||||
Returns the directory path as a string, C<undef> if the current user
|
||||
does not have a data directory, or dies on error.
|
||||
|
||||
|
||||
=head2 my_dist_config
|
||||
|
||||
File::HomeDir->my_dist_config( $dist [, \%params] );
|
||||
|
||||
# For example...
|
||||
|
||||
File::HomeDir->my_dist_config( 'File-HomeDir' );
|
||||
File::HomeDir->my_dist_config( 'File-HomeDir', { create => 1 } );
|
||||
|
||||
The C<my_dist_config> method takes a distribution name as argument and
|
||||
returns an application-specific directory where they should store their
|
||||
internal configuration.
|
||||
|
||||
The base directory will be either C<my_config> if the platform supports
|
||||
it, or C<my_documents> otherwise. The subdirectory itself will be
|
||||
C<BASE/Perl/Dist-Name>. If the base directory is the user's home directory,
|
||||
C<my_dist_config> will be in C<~/.perl/Dist-Name> (and thus be hidden on
|
||||
all Unixes).
|
||||
|
||||
The optional last argument is a hash reference to tweak the method
|
||||
behaviour. The following hash keys are recognized:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * create
|
||||
|
||||
Passing a true value to this key will force the creation of the
|
||||
directory if it doesn't exist (remember that C<File::HomeDir>'s policy
|
||||
is to return C<undef> if the directory doesn't exist).
|
||||
|
||||
Defaults to false, meaning no automatic creation of directory.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 my_dist_data
|
||||
|
||||
File::HomeDir->my_dist_data( $dist [, \%params] );
|
||||
|
||||
# For example...
|
||||
|
||||
File::HomeDir->my_dist_data( 'File-HomeDir' );
|
||||
File::HomeDir->my_dist_data( 'File-HomeDir', { create => 1 } );
|
||||
|
||||
The C<my_dist_data> method takes a distribution name as argument and
|
||||
returns an application-specific directory where they should store their
|
||||
internal data.
|
||||
|
||||
This directory will be of course a subdirectory of C<my_data>. Platforms
|
||||
supporting data-specific directories will use
|
||||
C<DATA_DIR/perl/dist/Dist-Name> following the common
|
||||
"DATA/vendor/application" pattern. If the C<my_data> directory is the
|
||||
user's home directory, C<my_dist_data> will be in C<~/.perl/dist/Dist-Name>
|
||||
(and thus be hidden on all Unixes).
|
||||
|
||||
The optional last argument is a hash reference to tweak the method
|
||||
behaviour. The following hash keys are recognized:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * create
|
||||
|
||||
Passing a true value to this key will force the creation of the
|
||||
directory if it doesn't exist (remember that C<File::HomeDir>'s policy
|
||||
is to return C<undef> if the directory doesn't exist).
|
||||
|
||||
Defaults to false, meaning no automatic creation of directory.
|
||||
|
||||
=back
|
||||
|
||||
=head2 users_home
|
||||
|
||||
$home = File::HomeDir->users_home('foo');
|
||||
|
||||
The C<users_home> method takes a single parameter and is used to locate the
|
||||
parent home/profile directory for an identified user on the system.
|
||||
|
||||
While most of the time this identifier would be some form of user name,
|
||||
it is permitted to vary per-platform to support user ids or UUIDs as
|
||||
applicable for that platform.
|
||||
|
||||
Returns the directory path as a string, C<undef> if that user
|
||||
does not have a home directory, or dies on error.
|
||||
|
||||
=head2 users_documents
|
||||
|
||||
$docs = File::HomeDir->users_documents('foo');
|
||||
|
||||
Returns the directory path as a string, C<undef> if that user
|
||||
does not have a documents directory, or dies on error.
|
||||
|
||||
=head2 users_data
|
||||
|
||||
$data = File::HomeDir->users_data('foo');
|
||||
|
||||
Returns the directory path as a string, C<undef> if that user
|
||||
does not have a data directory, or dies on error.
|
||||
|
||||
=head2 users_desktop
|
||||
|
||||
$docs = File::HomeDir->users_desktop('foo');
|
||||
|
||||
Returns the directory path as a string, C<undef> if that user
|
||||
does not have a desktop directory, or dies on error.
|
||||
|
||||
=head2 users_music
|
||||
|
||||
$docs = File::HomeDir->users_music('foo');
|
||||
|
||||
Returns the directory path as a string, C<undef> if that user
|
||||
does not have a music directory, or dies on error.
|
||||
|
||||
=head2 users_pictures
|
||||
|
||||
$docs = File::HomeDir->users_pictures('foo');
|
||||
|
||||
Returns the directory path as a string, C<undef> if that user
|
||||
does not have a pictures directory, or dies on error.
|
||||
|
||||
=head2 users_videos
|
||||
|
||||
$docs = File::HomeDir->users_videos('foo');
|
||||
|
||||
Returns the directory path as a string, C<undef> if that user
|
||||
does not have a videos directory, or dies on error.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 home
|
||||
|
||||
use File::HomeDir;
|
||||
$home = home();
|
||||
$home = home('foo');
|
||||
$home = File::HomeDir::home();
|
||||
$home = File::HomeDir::home('foo');
|
||||
|
||||
The C<home> function is exported by default and is provided for
|
||||
compatibility with legacy applications. In new applications, you should
|
||||
use the newer method-based interface above.
|
||||
|
||||
Returns the directory path to a named user's home/profile directory.
|
||||
|
||||
If provided no parameter, returns the directory path to the current user's
|
||||
home/profile directory.
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Add more granularity to Unix, and add support to VMS and other
|
||||
esoteric platforms, so we can consider going core.
|
||||
|
||||
=item * Add consistent support for users_* methods
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
This module is stored in an Open Repository at the following address.
|
||||
|
||||
L<http://svn.ali.as/cpan/trunk/File-HomeDir>
|
||||
|
||||
Write access to the repository is made available automatically to any
|
||||
published CPAN author, and to most other volunteers on request.
|
||||
|
||||
If you are able to submit your bug report in the form of new (failing)
|
||||
unit tests, or can apply your fix directly instead of submitting a patch,
|
||||
you are B<strongly> encouraged to do so as the author currently maintains
|
||||
over 100 modules and it can take some time to deal with non-Critical bug
|
||||
reports or patches.
|
||||
|
||||
This will guarantee that your issue will be addressed in the next
|
||||
release of the module.
|
||||
|
||||
If you cannot provide a direct test or fix, or don't have time to do so,
|
||||
then regular bug reports are still accepted and appreciated via the CPAN
|
||||
bug tracker.
|
||||
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-HomeDir>
|
||||
|
||||
For other issues, for commercial enhancement or support, or to have your
|
||||
write access enabled for the repository, contact the author at the email
|
||||
address above.
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
The biggest acknowledgement goes to Chris Nandor, who wielded his
|
||||
legendary Mac-fu and turned my initial fairly ordinary Darwin
|
||||
implementation into something that actually worked properly everywhere,
|
||||
and then donated a Mac OS X license to allow it to be maintained properly.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
Sean M. Burke E<lt>sburke@cpan.orgE<gt>
|
||||
|
||||
Chris Nandor E<lt>cnandor@cpan.orgE<gt>
|
||||
|
||||
Stephen Steneker E<lt>stennie@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::ShareDir>, L<File::HomeDir::Win32> (legacy)
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2012 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
Some parts copyright 2000 Sean M. Burke.
|
||||
|
||||
Some parts copyright 2006 Chris Nandor.
|
||||
|
||||
Some parts copyright 2006 Stephen Steneker.
|
||||
|
||||
Some parts copyright 2009-2011 Jérôme Quelin.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
152
database/perl/vendor/lib/File/HomeDir/Darwin.pm
vendored
Normal file
152
database/perl/vendor/lib/File/HomeDir/Darwin.pm
vendored
Normal file
@@ -0,0 +1,152 @@
|
||||
package File::HomeDir::Darwin;
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Cwd ();
|
||||
use Carp ();
|
||||
use File::HomeDir::Unix ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
use base "File::HomeDir::Unix";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
sub _my_home
|
||||
{
|
||||
my ($class, $path) = @_;
|
||||
my $home = $class->my_home;
|
||||
return undef unless defined $home;
|
||||
|
||||
my $folder = "$home/$path";
|
||||
unless (-d $folder)
|
||||
{
|
||||
# Make sure that symlinks resolve to directories.
|
||||
return undef unless -l $folder;
|
||||
my $dir = readlink $folder or return;
|
||||
return undef unless -d $dir;
|
||||
}
|
||||
|
||||
return Cwd::abs_path($folder);
|
||||
}
|
||||
|
||||
sub my_desktop
|
||||
{
|
||||
my $class = shift;
|
||||
$class->_my_home('Desktop');
|
||||
}
|
||||
|
||||
sub my_documents
|
||||
{
|
||||
my $class = shift;
|
||||
$class->_my_home('Documents');
|
||||
}
|
||||
|
||||
sub my_data
|
||||
{
|
||||
my $class = shift;
|
||||
$class->_my_home('Library/Application Support');
|
||||
}
|
||||
|
||||
sub my_music
|
||||
{
|
||||
my $class = shift;
|
||||
$class->_my_home('Music');
|
||||
}
|
||||
|
||||
sub my_pictures
|
||||
{
|
||||
my $class = shift;
|
||||
$class->_my_home('Pictures');
|
||||
}
|
||||
|
||||
sub my_videos
|
||||
{
|
||||
my $class = shift;
|
||||
$class->_my_home('Movies');
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Arbitrary User Methods
|
||||
|
||||
sub users_home
|
||||
{
|
||||
my $class = shift;
|
||||
my $home = $class->SUPER::users_home(@_);
|
||||
return defined $home ? Cwd::abs_path($home) : undef;
|
||||
}
|
||||
|
||||
sub users_desktop
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
return undef if $name eq 'root';
|
||||
$class->_to_user($class->my_desktop, $name);
|
||||
}
|
||||
|
||||
sub users_documents
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
return undef if $name eq 'root';
|
||||
$class->_to_user($class->my_documents, $name);
|
||||
}
|
||||
|
||||
sub users_data
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
$class->_to_user($class->my_data, $name)
|
||||
|| $class->users_home($name);
|
||||
}
|
||||
|
||||
# cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since
|
||||
# there's really no other good way to do it at this time, that i know of -- pudge
|
||||
sub _to_user
|
||||
{
|
||||
my ($class, $path, $name) = @_;
|
||||
my $my_home = $class->my_home;
|
||||
my $users_home = $class->users_home($name);
|
||||
defined $users_home or return undef;
|
||||
$path =~ s/^\Q$my_home/$users_home/;
|
||||
return $path;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::Darwin - Find your home and other directories on Darwin (OS X)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides Mac OS X specific file path for determining
|
||||
common user directories in pure perl, by just using C<$ENV{HOME}>
|
||||
without Carbon nor Cocoa API calls. In normal usage this module will
|
||||
always be used via L<File::HomeDir>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Find directories for the current user
|
||||
$home = File::HomeDir->my_home; # /Users/mylogin
|
||||
$desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop
|
||||
$docs = File::HomeDir->my_documents; # /Users/mylogin/Documents
|
||||
$music = File::HomeDir->my_music; # /Users/mylogin/Music
|
||||
$pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures
|
||||
$videos = File::HomeDir->my_videos; # /Users/mylogin/Movies
|
||||
$data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2009 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
=cut
|
||||
205
database/perl/vendor/lib/File/HomeDir/Darwin/Carbon.pm
vendored
Normal file
205
database/perl/vendor/lib/File/HomeDir/Darwin/Carbon.pm
vendored
Normal file
@@ -0,0 +1,205 @@
|
||||
package File::HomeDir::Darwin::Carbon;
|
||||
|
||||
# Basic implementation for the Dawin family of operating systems.
|
||||
# This includes (most prominently) Mac OS X.
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Cwd ();
|
||||
use Carp ();
|
||||
use File::HomeDir::Darwin ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
|
||||
# This is only a child class of the pure Perl darwin
|
||||
# class so that we can do homedir detection of all three
|
||||
# drivers at one via ->isa.
|
||||
use base "File::HomeDir::Darwin";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
|
||||
# Load early if in a forking environment and we have
|
||||
# prefork, or at run-time if not.
|
||||
local $@; ## no critic (Variables::RequireInitializationForLocalVars)
|
||||
eval "use prefork 'Mac::Files'"; ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
## no critic qw(UnusedPrivateSubroutines)
|
||||
sub _guess_determined_home
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::Files;
|
||||
my $home = $class->_find_folder(Mac::Files::kCurrentUserFolderType(),);
|
||||
$home ||= $class->SUPER::_guess_determined_home($@);
|
||||
return $home;
|
||||
}
|
||||
|
||||
sub my_desktop
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::Files;
|
||||
$class->_find_folder(Mac::Files::kDesktopFolderType(),);
|
||||
}
|
||||
|
||||
sub my_documents
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::Files;
|
||||
$class->_find_folder(Mac::Files::kDocumentsFolderType(),);
|
||||
}
|
||||
|
||||
sub my_data
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::Files;
|
||||
$class->_find_folder(Mac::Files::kApplicationSupportFolderType(),);
|
||||
}
|
||||
|
||||
sub my_music
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::Files;
|
||||
$class->_find_folder(Mac::Files::kMusicDocumentsFolderType(),);
|
||||
}
|
||||
|
||||
sub my_pictures
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::Files;
|
||||
$class->_find_folder(Mac::Files::kPictureDocumentsFolderType(),);
|
||||
}
|
||||
|
||||
sub my_videos
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::Files;
|
||||
$class->_find_folder(Mac::Files::kMovieDocumentsFolderType(),);
|
||||
}
|
||||
|
||||
sub _find_folder
|
||||
{
|
||||
my $class = shift;
|
||||
my $name = shift;
|
||||
|
||||
require Mac::Files;
|
||||
my $folder = Mac::Files::FindFolder(Mac::Files::kUserDomain(), $name,);
|
||||
return undef unless defined $folder;
|
||||
|
||||
unless (-d $folder)
|
||||
{
|
||||
# Make sure that symlinks resolve to directories.
|
||||
return undef unless -l $folder;
|
||||
my $dir = readlink $folder or return;
|
||||
return undef unless -d $dir;
|
||||
}
|
||||
|
||||
return Cwd::abs_path($folder);
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Arbitrary User Methods
|
||||
|
||||
sub users_home
|
||||
{
|
||||
my $class = shift;
|
||||
my $home = $class->SUPER::users_home(@_);
|
||||
return defined $home ? Cwd::abs_path($home) : undef;
|
||||
}
|
||||
|
||||
# in theory this can be done, but for now, let's cheat, since the
|
||||
# rest is Hard
|
||||
sub users_desktop
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
return undef if $name eq 'root';
|
||||
$class->_to_user($class->my_desktop, $name);
|
||||
}
|
||||
|
||||
sub users_documents
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
return undef if $name eq 'root';
|
||||
$class->_to_user($class->my_documents, $name);
|
||||
}
|
||||
|
||||
sub users_data
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
$class->_to_user($class->my_data, $name)
|
||||
|| $class->users_home($name);
|
||||
}
|
||||
|
||||
# cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since
|
||||
# there's really no other good way to do it at this time, that i know of -- pudge
|
||||
sub _to_user
|
||||
{
|
||||
my ($class, $path, $name) = @_;
|
||||
my $my_home = $class->my_home;
|
||||
my $users_home = $class->users_home($name);
|
||||
defined $users_home or return undef;
|
||||
$path =~ s/^\Q$my_home/$users_home/;
|
||||
return $path;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::Darwin - Find your home and other directories on Darwin (OS X)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides Darwin-specific implementations for determining
|
||||
common user directories. In normal usage this module will always be
|
||||
used via L<File::HomeDir>.
|
||||
|
||||
Note -- since this module requires Mac::Carbon and Mac::Carbon does
|
||||
not work with 64-bit perls, on such systems, File::HomeDir will try
|
||||
L<File::HomeDir::Darwin::Cocoa> and then fall back to the (pure Perl)
|
||||
L<File::HomeDir::Darwin>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Find directories for the current user
|
||||
$home = File::HomeDir->my_home; # /Users/mylogin
|
||||
$desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop
|
||||
$docs = File::HomeDir->my_documents; # /Users/mylogin/Documents
|
||||
$music = File::HomeDir->my_music; # /Users/mylogin/Music
|
||||
$pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures
|
||||
$videos = File::HomeDir->my_videos; # /Users/mylogin/Movies
|
||||
$data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support
|
||||
|
||||
=head1 TODO
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Test with Mac OS (versions 7, 8, 9)
|
||||
|
||||
=item * Some better way for users_* ?
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2009 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
=cut
|
||||
157
database/perl/vendor/lib/File/HomeDir/Darwin/Cocoa.pm
vendored
Normal file
157
database/perl/vendor/lib/File/HomeDir/Darwin/Cocoa.pm
vendored
Normal file
@@ -0,0 +1,157 @@
|
||||
package File::HomeDir::Darwin::Cocoa;
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Cwd ();
|
||||
use Carp ();
|
||||
use File::HomeDir::Darwin ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
use base "File::HomeDir::Darwin";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
|
||||
# Load early if in a forking environment and we have
|
||||
# prefork, or at run-time if not.
|
||||
local $@; ## no critic (Variables::RequireInitializationForLocalVars)
|
||||
eval "use prefork 'Mac::SystemDirectory'"; ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
## no critic qw(UnusedPrivateSubroutines)
|
||||
sub _guess_determined_home
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
my $home = Mac::SystemDirectory::HomeDirectory();
|
||||
$home ||= $class->SUPER::_guess_determined_home($@);
|
||||
return $home;
|
||||
}
|
||||
|
||||
# from 10.4
|
||||
sub my_desktop
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
eval { $class->_find_folder(Mac::SystemDirectory::NSDesktopDirectory()) }
|
||||
|| $class->SUPER::my_desktop;
|
||||
}
|
||||
|
||||
# from 10.2
|
||||
sub my_documents
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
eval { $class->_find_folder(Mac::SystemDirectory::NSDocumentDirectory()) }
|
||||
|| $class->SUPER::my_documents;
|
||||
}
|
||||
|
||||
# from 10.4
|
||||
sub my_data
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
eval { $class->_find_folder(Mac::SystemDirectory::NSApplicationSupportDirectory()) }
|
||||
|| $class->SUPER::my_data;
|
||||
}
|
||||
|
||||
# from 10.6
|
||||
sub my_music
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
eval { $class->_find_folder(Mac::SystemDirectory::NSMusicDirectory()) }
|
||||
|| $class->SUPER::my_music;
|
||||
}
|
||||
|
||||
# from 10.6
|
||||
sub my_pictures
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
eval { $class->_find_folder(Mac::SystemDirectory::NSPicturesDirectory()) }
|
||||
|| $class->SUPER::my_pictures;
|
||||
}
|
||||
|
||||
# from 10.6
|
||||
sub my_videos
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
eval { $class->_find_folder(Mac::SystemDirectory::NSMoviesDirectory()) }
|
||||
|| $class->SUPER::my_videos;
|
||||
}
|
||||
|
||||
sub _find_folder
|
||||
{
|
||||
my $class = shift;
|
||||
my $name = shift;
|
||||
|
||||
require Mac::SystemDirectory;
|
||||
my $folder = Mac::SystemDirectory::FindDirectory($name);
|
||||
return undef unless defined $folder;
|
||||
|
||||
unless (-d $folder)
|
||||
{
|
||||
# Make sure that symlinks resolve to directories.
|
||||
return undef unless -l $folder;
|
||||
my $dir = readlink $folder or return;
|
||||
return undef unless -d $dir;
|
||||
}
|
||||
|
||||
return Cwd::abs_path($folder);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::Darwin::Cocoa - Find your home and other directories on Darwin (OS X)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides Darwin-specific implementations for determining
|
||||
common user directories using Cocoa API through
|
||||
L<Mac::SystemDirectory>. In normal usage this module will always be
|
||||
used via L<File::HomeDir>.
|
||||
|
||||
Theoretically, this should return the same paths as both of the other
|
||||
Darwin drivers.
|
||||
|
||||
Because this module requires L<Mac::SystemDirectory>, if the module
|
||||
is not installed, L<File::HomeDir> will fall back to L<File::HomeDir::Darwin>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Find directories for the current user
|
||||
$home = File::HomeDir->my_home; # /Users/mylogin
|
||||
$desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop
|
||||
$docs = File::HomeDir->my_documents; # /Users/mylogin/Documents
|
||||
$music = File::HomeDir->my_music; # /Users/mylogin/Music
|
||||
$pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures
|
||||
$videos = File::HomeDir->my_videos; # /Users/mylogin/Movies
|
||||
$data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2009 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
=cut
|
||||
60
database/perl/vendor/lib/File/HomeDir/Driver.pm
vendored
Normal file
60
database/perl/vendor/lib/File/HomeDir/Driver.pm
vendored
Normal file
@@ -0,0 +1,60 @@
|
||||
package File::HomeDir::Driver;
|
||||
|
||||
# Abstract base class that provides no functionality,
|
||||
# but confirms the class is a File::HomeDir driver class.
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
}
|
||||
|
||||
sub my_home
|
||||
{
|
||||
Carp::croak("$_[0] does not implement compulsory method $_[1]");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::Driver - Base class for all File::HomeDir drivers
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is the base class for all L<File::HomeDir> drivers, and must
|
||||
be inherited from to identify a class as a driver.
|
||||
|
||||
It is primarily provided as a convenience for this specific identification
|
||||
purpose, as L<File::HomeDir> supports the specification of custom drivers
|
||||
and an C<-E<gt>isa> check is used during the loading of the driver.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::HomeDir>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2009 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
145
database/perl/vendor/lib/File/HomeDir/FreeDesktop.pm
vendored
Normal file
145
database/perl/vendor/lib/File/HomeDir/FreeDesktop.pm
vendored
Normal file
@@ -0,0 +1,145 @@
|
||||
package File::HomeDir::FreeDesktop;
|
||||
|
||||
# Specific functionality for unixes running free desktops
|
||||
# compatible with (but not using) File-BaseDir-0.03
|
||||
|
||||
# See POD at the end of the file for more documentation.
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use File::Spec ();
|
||||
use File::Which ();
|
||||
use File::HomeDir::Unix ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
use base "File::HomeDir::Unix";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
}
|
||||
|
||||
# xdg uses $ENV{XDG_CONFIG_HOME}/user-dirs.dirs to know where are the
|
||||
# various "my xxx" directories. That is a shell file. The official API
|
||||
# is the xdg-user-dir executable. It has no provision for assessing
|
||||
# the directories of a user that is different than the one we are
|
||||
# running under; the standard substitute user mechanisms are needed to
|
||||
# overcome this.
|
||||
|
||||
my $xdgprog = File::Which::which('xdg-user-dir');
|
||||
|
||||
sub _my
|
||||
{
|
||||
# No quoting because input is hard-coded and only comes from this module
|
||||
my $thingy = qx($xdgprog $_[1]);
|
||||
chomp $thingy;
|
||||
return $thingy;
|
||||
}
|
||||
|
||||
# Simple stuff
|
||||
sub my_desktop { shift->_my('DESKTOP') }
|
||||
sub my_documents { shift->_my('DOCUMENTS') }
|
||||
sub my_music { shift->_my('MUSIC') }
|
||||
sub my_pictures { shift->_my('PICTURES') }
|
||||
sub my_videos { shift->_my('VIDEOS') }
|
||||
|
||||
sub my_data
|
||||
{
|
||||
$ENV{XDG_DATA_HOME}
|
||||
or File::Spec->catdir(shift->my_home, qw{ .local share });
|
||||
}
|
||||
|
||||
sub my_config
|
||||
{
|
||||
$ENV{XDG_CONFIG_HOME}
|
||||
or File::Spec->catdir(shift->my_home, qw{ .config });
|
||||
}
|
||||
|
||||
# Custom locations (currently undocumented)
|
||||
sub my_download { shift->_my('DOWNLOAD') }
|
||||
sub my_publicshare { shift->_my('PUBLICSHARE') }
|
||||
sub my_templates { shift->_my('TEMPLATES') }
|
||||
|
||||
sub my_cache
|
||||
{
|
||||
$ENV{XDG_CACHE_HOME}
|
||||
|| File::Spec->catdir(shift->my_home, qw{ .cache });
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# General User Methods
|
||||
|
||||
sub users_desktop { Carp::croak('The users_desktop method is not available on an XDG based system.'); }
|
||||
sub users_documents { Carp::croak('The users_documents method is not available on an XDG based system.'); }
|
||||
sub users_music { Carp::croak('The users_music method is not available on an XDG based system.'); }
|
||||
sub users_pictures { Carp::croak('The users_pictures method is not available on an XDG based system.'); }
|
||||
sub users_videos { Carp::croak('The users_videos method is not available on an XDG based system.'); }
|
||||
sub users_data { Carp::croak('The users_data method is not available on an XDG based system.'); }
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::FreeDesktop - Find your home and other directories on FreeDesktop.org Unix
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides implementations for determining common user
|
||||
directories. In normal usage this module will always be
|
||||
used via L<File::HomeDir>.
|
||||
|
||||
This module can operate only when the command C<xdg-user-dir> is available
|
||||
and executable, which is typically achieved by installed a package named
|
||||
C<xdg-user-dirs> or similar.
|
||||
|
||||
One can find the latest spec at L<https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Find directories for the current user
|
||||
$home = File::HomeDir->my_home; # /home/mylogin
|
||||
$desktop = File::HomeDir->my_desktop;
|
||||
$docs = File::HomeDir->my_documents;
|
||||
$music = File::HomeDir->my_music;
|
||||
$pics = File::HomeDir->my_pictures;
|
||||
$videos = File::HomeDir->my_videos;
|
||||
$data = File::HomeDir->my_data;
|
||||
$config = File::HomeDir->my_config;
|
||||
|
||||
# Some undocumented ones, expect they don't work - use with caution
|
||||
$download = File::HomeDir->my_download;
|
||||
$publicshare = File::HomeDir->my_publicshare;
|
||||
$templates = File::HomeDir->my_templates;
|
||||
$cache = File::HomeDir->my_cache;
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Jerome Quelin E<lt>jquellin@cpan.org<gt>
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::HomeDir>, L<File::HomeDir::Win32> (legacy)
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2009 - 2011 Jerome Quelin.
|
||||
|
||||
Some parts copyright 2010 Adam Kennedy.
|
||||
|
||||
Some parts copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
154
database/perl/vendor/lib/File/HomeDir/MacOS9.pm
vendored
Normal file
154
database/perl/vendor/lib/File/HomeDir/MacOS9.pm
vendored
Normal file
@@ -0,0 +1,154 @@
|
||||
package File::HomeDir::MacOS9;
|
||||
|
||||
# Half-assed implementation for the legacy Mac OS9 operating system.
|
||||
# Provided mainly to provide legacy compatibility. May be removed at
|
||||
# a later date.
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use File::HomeDir::Driver ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
use base "File::HomeDir::Driver";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
}
|
||||
|
||||
# Load early if in a forking environment and we have
|
||||
# prefork, or at run-time if not.
|
||||
SCOPE:
|
||||
{
|
||||
## no critic qw(RequireInitializationForLocalVars, RequireCheckingReturnValueOfEval)
|
||||
local $@;
|
||||
eval "use prefork 'Mac::Files'";
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
sub my_home
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# Try for $ENV{HOME} if we have it
|
||||
if (defined $ENV{HOME})
|
||||
{
|
||||
return $ENV{HOME};
|
||||
}
|
||||
|
||||
### DESPERATION SETS IN
|
||||
|
||||
# We could use the desktop
|
||||
SCOPE:
|
||||
{
|
||||
## no critic qw(RequireInitializationForLocalVars, RequireCheckingReturnValueOfEval)
|
||||
local $@;
|
||||
eval {
|
||||
my $home = $class->my_desktop;
|
||||
return $home if $home and -d $home;
|
||||
};
|
||||
}
|
||||
|
||||
# Desperation on any platform
|
||||
SCOPE:
|
||||
{
|
||||
# On some platforms getpwuid dies if called at all
|
||||
local $SIG{'__DIE__'} = '';
|
||||
my $home = (getpwuid($<))[7];
|
||||
return $home if $home and -d $home;
|
||||
}
|
||||
|
||||
Carp::croak("Could not locate current user's home directory");
|
||||
}
|
||||
|
||||
sub my_desktop
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# Find the desktop via Mac::Files
|
||||
local $SIG{'__DIE__'} = '';
|
||||
require Mac::Files;
|
||||
my $home = Mac::Files::FindFolder(Mac::Files::kOnSystemDisk(), Mac::Files::kDesktopFolderType(),);
|
||||
return $home if $home and -d $home;
|
||||
|
||||
Carp::croak("Could not locate current user's desktop");
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# General User Methods
|
||||
|
||||
sub users_home
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
|
||||
SCOPE:
|
||||
{
|
||||
# On some platforms getpwnam dies if called at all
|
||||
local $SIG{'__DIE__'} = '';
|
||||
my $home = (getpwnam($name))[7];
|
||||
return $home if defined $home and -d $home;
|
||||
}
|
||||
|
||||
Carp::croak("Failed to find home directory for user '$name'");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::MacOS9 - Find your home and other directories on legacy Macintosh systems
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Find directories for the current user
|
||||
$home = File::HomeDir->my_home;
|
||||
$desktop = File::HomeDir->my_desktop;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides implementations for determining common user
|
||||
directories on legacy Mac hosts. In normal usage this module will always be
|
||||
used via L<File::HomeDir>.
|
||||
|
||||
This module is no longer actively maintained, and is included only for
|
||||
extreme back-compatibility.
|
||||
|
||||
Only the C<my_home> and C<my_desktop> methods are supported.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
See the support section the main L<File::HomeDir> module.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
Sean M. Burke E<lt>sburke@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::HomeDir>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
Some parts copyright 2000 Sean M. Burke.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
147
database/perl/vendor/lib/File/HomeDir/Test.pm
vendored
Normal file
147
database/perl/vendor/lib/File/HomeDir/Test.pm
vendored
Normal file
@@ -0,0 +1,147 @@
|
||||
package File::HomeDir::Test;
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use File::Spec ();
|
||||
use File::Temp ();
|
||||
use File::HomeDir::Driver ();
|
||||
|
||||
use vars qw{$VERSION %DIR $ENABLED};
|
||||
use base "File::HomeDir::Driver";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
%DIR = ();
|
||||
$ENABLED = 0;
|
||||
}
|
||||
|
||||
# Special magic use in test scripts
|
||||
sub import
|
||||
{
|
||||
my $class = shift;
|
||||
Carp::croak "Attempted to initialise File::HomeDir::Test trice" if %DIR;
|
||||
|
||||
# Fill the test directories
|
||||
my $BASE = File::Temp::tempdir(CLEANUP => 1);
|
||||
%DIR = map { $_ => File::Spec->catdir($BASE, $_) } qw{
|
||||
my_home
|
||||
my_desktop
|
||||
my_documents
|
||||
my_data
|
||||
my_music
|
||||
my_pictures
|
||||
my_videos
|
||||
};
|
||||
|
||||
# Hijack HOME to the home directory
|
||||
$ENV{HOME} = $DIR{my_home}; ## no critic qw(LocalizedPunctuationVars)
|
||||
|
||||
# Make File::HomeDir load us instead of the native driver
|
||||
$File::HomeDir::IMPLEMENTED_BY = # Prevent a warning
|
||||
$File::HomeDir::IMPLEMENTED_BY = 'File::HomeDir::Test';
|
||||
|
||||
# Ready to go
|
||||
$ENABLED = 1;
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
sub my_home
|
||||
{
|
||||
mkdir($DIR{my_home}, oct(755)) unless -d $DIR{my_home};
|
||||
return $DIR{my_home};
|
||||
}
|
||||
|
||||
sub my_desktop
|
||||
{
|
||||
mkdir($DIR{my_desktop}, oct(755)) unless -d $DIR{my_desktop};
|
||||
return $DIR{my_desktop};
|
||||
}
|
||||
|
||||
sub my_documents
|
||||
{
|
||||
mkdir($DIR{my_documents}, oct(755)) unless -f $DIR{my_documents};
|
||||
return $DIR{my_documents};
|
||||
}
|
||||
|
||||
sub my_data
|
||||
{
|
||||
mkdir($DIR{my_data}, oct(755)) unless -d $DIR{my_data};
|
||||
return $DIR{my_data};
|
||||
}
|
||||
|
||||
sub my_music
|
||||
{
|
||||
mkdir($DIR{my_music}, oct(755)) unless -d $DIR{my_music};
|
||||
return $DIR{my_music};
|
||||
}
|
||||
|
||||
sub my_pictures
|
||||
{
|
||||
mkdir($DIR{my_pictures}, oct(755)) unless -d $DIR{my_pictures};
|
||||
return $DIR{my_pictures};
|
||||
}
|
||||
|
||||
sub my_videos
|
||||
{
|
||||
mkdir($DIR{my_videos}, oct(755)) unless -d $DIR{my_videos};
|
||||
return $DIR{my_videos};
|
||||
}
|
||||
|
||||
sub users_home
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::Test - Prevent the accidental creation of user-owned files during testing
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::More test => 1;
|
||||
use File::HomeDir::Test;
|
||||
use File::HomeDir;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<File::HomeDir::Test> is a L<File::HomeDir> driver intended for use in the test scripts
|
||||
of modules or applications that write files into user-owned directories.
|
||||
|
||||
It is designed to prevent the pollution of user directories with files that are not part
|
||||
of the application install itself, but were created during testing. These files can leak
|
||||
state information from the tests into the run-time usage of an application, and on Unix
|
||||
systems also prevents tests (which may be executed as root via sudo) from writing files
|
||||
which cannot later be modified or removed by the regular user.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
See the support section of the main L<File::HomeDir> documentation.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
217
database/perl/vendor/lib/File/HomeDir/Unix.pm
vendored
Normal file
217
database/perl/vendor/lib/File/HomeDir/Unix.pm
vendored
Normal file
@@ -0,0 +1,217 @@
|
||||
package File::HomeDir::Unix;
|
||||
|
||||
# See POD at the end of the file for documentation
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use File::HomeDir::Driver ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
use base "File::HomeDir::Driver";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
sub my_home
|
||||
{
|
||||
my $class = shift;
|
||||
my $home = $class->_guess_home(@_);
|
||||
|
||||
# On Unix in general, a non-existent home means "no home"
|
||||
# For example, "nobody"-like users might use /nonexistent
|
||||
if (defined $home and not -d $home)
|
||||
{
|
||||
$home = undef;
|
||||
}
|
||||
|
||||
return $home;
|
||||
}
|
||||
|
||||
sub _guess_env_home
|
||||
{
|
||||
my $class = shift;
|
||||
if (exists $ENV{HOME} and defined $ENV{HOME} and length $ENV{HOME})
|
||||
{
|
||||
return $ENV{HOME};
|
||||
}
|
||||
|
||||
# This is from the original code, but I'm guessing
|
||||
# it means "login directory" and exists on some Unixes.
|
||||
if (exists $ENV{LOGDIR} and $ENV{LOGDIR})
|
||||
{
|
||||
return $ENV{LOGDIR};
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _guess_determined_home
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# Light desperation on any (Unixish) platform
|
||||
SCOPE:
|
||||
{
|
||||
my $home = (getpwuid($<))[7];
|
||||
return $home if $home and -d $home;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _guess_home
|
||||
{
|
||||
my $class = shift;
|
||||
my $home = $class->_guess_env_home($@);
|
||||
$home ||= $class->_guess_determined_home($@);
|
||||
return $home;
|
||||
}
|
||||
|
||||
# On unix by default, everything is under the same folder
|
||||
sub my_desktop
|
||||
{
|
||||
shift->my_home;
|
||||
}
|
||||
|
||||
sub my_documents
|
||||
{
|
||||
shift->my_home;
|
||||
}
|
||||
|
||||
sub my_data
|
||||
{
|
||||
shift->my_home;
|
||||
}
|
||||
|
||||
sub my_music
|
||||
{
|
||||
shift->my_home;
|
||||
}
|
||||
|
||||
sub my_pictures
|
||||
{
|
||||
shift->my_home;
|
||||
}
|
||||
|
||||
sub my_videos
|
||||
{
|
||||
shift->my_home;
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# General User Methods
|
||||
|
||||
sub users_home
|
||||
{
|
||||
my ($class, $name) = @_;
|
||||
|
||||
# IF and only if we have getpwuid support, and the
|
||||
# name of the user is our own, shortcut to my_home.
|
||||
# This is needed to handle HOME environment settings.
|
||||
if ($name eq getpwuid($<))
|
||||
{
|
||||
return $class->my_home;
|
||||
}
|
||||
|
||||
SCOPE:
|
||||
{
|
||||
my $home = (getpwnam($name))[7];
|
||||
return $home if $home and -d $home;
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub users_desktop
|
||||
{
|
||||
shift->users_home(@_);
|
||||
}
|
||||
|
||||
sub users_documents
|
||||
{
|
||||
shift->users_home(@_);
|
||||
}
|
||||
|
||||
sub users_data
|
||||
{
|
||||
shift->users_home(@_);
|
||||
}
|
||||
|
||||
sub users_music
|
||||
{
|
||||
shift->users_home(@_);
|
||||
}
|
||||
|
||||
sub users_pictures
|
||||
{
|
||||
shift->users_home(@_);
|
||||
}
|
||||
|
||||
sub users_videos
|
||||
{
|
||||
shift->users_home(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::Unix - Find your home and other directories on legacy Unix
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Find directories for the current user
|
||||
$home = File::HomeDir->my_home; # /home/mylogin
|
||||
$desktop = File::HomeDir->my_desktop; # All of these will...
|
||||
$docs = File::HomeDir->my_documents; # ...default to home...
|
||||
$music = File::HomeDir->my_music; # ...directory
|
||||
$pics = File::HomeDir->my_pictures; #
|
||||
$videos = File::HomeDir->my_videos; #
|
||||
$data = File::HomeDir->my_data; #
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides implementations for determining common user
|
||||
directories. In normal usage this module will always be
|
||||
used via L<File::HomeDir>.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
See the support section the main L<File::HomeDir> module.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
Sean M. Burke E<lt>sburke@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::HomeDir>, L<File::HomeDir::Win32> (legacy)
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
Some parts copyright 2000 Sean M. Burke.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
260
database/perl/vendor/lib/File/HomeDir/Windows.pm
vendored
Normal file
260
database/perl/vendor/lib/File/HomeDir/Windows.pm
vendored
Normal file
@@ -0,0 +1,260 @@
|
||||
package File::HomeDir::Windows;
|
||||
|
||||
# See POD at the end of the file for documentation
|
||||
|
||||
use 5.008003;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use File::Spec ();
|
||||
use File::HomeDir::Driver ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
use base "File::HomeDir::Driver";
|
||||
|
||||
BEGIN
|
||||
{
|
||||
$VERSION = '1.006';
|
||||
}
|
||||
|
||||
sub CREATE () { 1 }
|
||||
|
||||
#####################################################################
|
||||
# Current User Methods
|
||||
|
||||
sub my_home
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# A lot of unix people and unix-derived tools rely on
|
||||
# the ability to overload HOME. We will support it too
|
||||
# so that they can replace raw HOME calls with File::HomeDir.
|
||||
if (exists $ENV{HOME} and defined $ENV{HOME} and length $ENV{HOME})
|
||||
{
|
||||
return $ENV{HOME};
|
||||
}
|
||||
|
||||
# Do we have a user profile?
|
||||
if (exists $ENV{USERPROFILE} and $ENV{USERPROFILE})
|
||||
{
|
||||
return $ENV{USERPROFILE};
|
||||
}
|
||||
|
||||
# Some Windows use something like $ENV{HOME}
|
||||
if (exists $ENV{HOMEDRIVE} and exists $ENV{HOMEPATH} and $ENV{HOMEDRIVE} and $ENV{HOMEPATH})
|
||||
{
|
||||
return File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '',);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub my_desktop
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# The most correct way to find the desktop
|
||||
SCOPE:
|
||||
{
|
||||
require Win32;
|
||||
my $dir = Win32::GetFolderPath(Win32::CSIDL_DESKTOP(), CREATE);
|
||||
return $dir if $dir and $class->_d($dir);
|
||||
}
|
||||
|
||||
# MSWindows sets WINDIR, MS WinNT sets USERPROFILE.
|
||||
foreach my $e ('USERPROFILE', 'WINDIR')
|
||||
{
|
||||
next unless $ENV{$e};
|
||||
my $desktop = File::Spec->catdir($ENV{$e}, 'Desktop');
|
||||
return $desktop if $desktop and $class->_d($desktop);
|
||||
}
|
||||
|
||||
# As a last resort, try some hard-wired values
|
||||
foreach my $fixed (
|
||||
# The reason there are both types of slash here is because
|
||||
# this set of paths has been kept from the original version
|
||||
# of File::HomeDir::Win32 (before it was rewritten).
|
||||
# I can only assume this is Cygwin-related stuff.
|
||||
"C:\\windows\\desktop",
|
||||
"C:\\win95\\desktop",
|
||||
"C:/win95/desktop",
|
||||
"C:/windows/desktop",
|
||||
)
|
||||
{
|
||||
return $fixed if $class->_d($fixed);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub my_documents
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# The most correct way to find my documents
|
||||
SCOPE:
|
||||
{
|
||||
require Win32;
|
||||
my $dir = Win32::GetFolderPath(Win32::CSIDL_PERSONAL(), CREATE);
|
||||
return $dir if $dir and $class->_d($dir);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub my_data
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# The most correct way to find my documents
|
||||
SCOPE:
|
||||
{
|
||||
require Win32;
|
||||
my $dir = Win32::GetFolderPath(Win32::CSIDL_LOCAL_APPDATA(), CREATE);
|
||||
return $dir if $dir and $class->_d($dir);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub my_music
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# The most correct way to find my music
|
||||
SCOPE:
|
||||
{
|
||||
require Win32;
|
||||
my $dir = Win32::GetFolderPath(Win32::CSIDL_MYMUSIC(), CREATE);
|
||||
return $dir if $dir and $class->_d($dir);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub my_pictures
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# The most correct way to find my pictures
|
||||
SCOPE:
|
||||
{
|
||||
require Win32;
|
||||
my $dir = Win32::GetFolderPath(Win32::CSIDL_MYPICTURES(), CREATE);
|
||||
return $dir if $dir and $class->_d($dir);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub my_videos
|
||||
{
|
||||
my $class = shift;
|
||||
|
||||
# The most correct way to find my videos
|
||||
SCOPE:
|
||||
{
|
||||
require Win32;
|
||||
my $dir = Win32::GetFolderPath(Win32::CSIDL_MYVIDEO(), CREATE);
|
||||
return $dir if $dir and $class->_d($dir);
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Special case version of -d
|
||||
sub _d
|
||||
{
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
|
||||
# Window can legally return a UNC path from GetFolderPath.
|
||||
# Not only is the meaning of -d complicated in this situation,
|
||||
# but even on a local network calling -d "\\\\cifs\\path" can
|
||||
# take several seconds. UNC can also do even weirder things,
|
||||
# like launching processes and such.
|
||||
# To avoid various crazy bugs caused by this, we do NOT attempt
|
||||
# to validate UNC paths at all so that the code that is calling
|
||||
# us has an opportunity to take special actions without our
|
||||
# blundering getting in the way.
|
||||
if ($path =~ /\\\\/)
|
||||
{
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Otherwise do a stat as normal
|
||||
return -d $path;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::HomeDir::Windows - Find your home and other directories on Windows
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::HomeDir;
|
||||
|
||||
# Find directories for the current user (eg. using Windows XP Professional)
|
||||
$home = File::HomeDir->my_home; # C:\Documents and Settings\mylogin
|
||||
$desktop = File::HomeDir->my_desktop; # C:\Documents and Settings\mylogin\Desktop
|
||||
$docs = File::HomeDir->my_documents; # C:\Documents and Settings\mylogin\My Documents
|
||||
$music = File::HomeDir->my_music; # C:\Documents and Settings\mylogin\My Documents\My Music
|
||||
$pics = File::HomeDir->my_pictures; # C:\Documents and Settings\mylogin\My Documents\My Pictures
|
||||
$videos = File::HomeDir->my_videos; # C:\Documents and Settings\mylogin\My Documents\My Video
|
||||
$data = File::HomeDir->my_data; # C:\Documents and Settings\mylogin\Local Settings\Application Data
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides Windows-specific implementations for determining
|
||||
common user directories. In normal usage this module will always be
|
||||
used via L<File::HomeDir>.
|
||||
|
||||
Internally this module will use L<Win32>::GetFolderPath to fetch the location
|
||||
of your directories. As a result of this, in certain unusual situations
|
||||
(usually found inside large organizations) the methods may return UNC paths
|
||||
such as C<\\cifs.local\home$>.
|
||||
|
||||
If your application runs on Windows and you want to have it work comprehensively
|
||||
everywhere, you may need to implement your own handling for these paths as they
|
||||
can cause strange behaviour.
|
||||
|
||||
For example, stat calls to UNC paths may work but block for several seconds, but
|
||||
opendir() may not be able to read any files (creating the appearance of an existing
|
||||
but empty directory).
|
||||
|
||||
To avoid complicating the problem any further, in the rare situation that a UNC path
|
||||
is returned by C<GetFolderPath> the usual -d validation checks will B<not> be done.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
See the support section the main L<File::HomeDir> module.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
Sean M. Burke E<lt>sburke@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::HomeDir>, L<File::HomeDir::Win32> (legacy)
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2011 Adam Kennedy.
|
||||
|
||||
Copyright 2017 - 2020 Jens Rehsack
|
||||
|
||||
Some parts copyright 2000 Sean M. Burke.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
616
database/perl/vendor/lib/File/Listing.pm
vendored
Normal file
616
database/perl/vendor/lib/File/Listing.pm
vendored
Normal file
@@ -0,0 +1,616 @@
|
||||
package File::Listing;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use HTTP::Date qw(str2time);
|
||||
use base qw( Exporter );
|
||||
|
||||
# ABSTRACT: Parse directory listing
|
||||
our $VERSION = '6.14'; # VERSION
|
||||
|
||||
sub Version { $File::Listing::VERSION; }
|
||||
|
||||
our @EXPORT = qw(parse_dir);
|
||||
|
||||
sub parse_dir ($;$$$)
|
||||
{
|
||||
my($dir, $tz, $fstype, $error) = @_;
|
||||
|
||||
$fstype ||= 'unix';
|
||||
$fstype = "File::Listing::" . lc $fstype;
|
||||
|
||||
my @args = $_[0];
|
||||
push(@args, $tz) if(@_ >= 2);
|
||||
push(@args, $error) if(@_ >= 4);
|
||||
|
||||
$fstype->parse(@args);
|
||||
}
|
||||
|
||||
|
||||
sub line { Carp::croak("Not implemented yet"); }
|
||||
sub init { } # Dummy sub
|
||||
|
||||
|
||||
sub file_mode ($)
|
||||
{
|
||||
Carp::croak("Input to file_mode() must be a 10 character string.")
|
||||
unless length($_[0]) == 10;
|
||||
|
||||
# This routine was originally borrowed from Graham Barr's
|
||||
# Net::FTP package.
|
||||
|
||||
local $_ = shift;
|
||||
my $mode = 0;
|
||||
my($type);
|
||||
|
||||
s/^(.)// and $type = $1;
|
||||
|
||||
# When the set-group-ID bit (file mode bit 02000) is set, and the group
|
||||
# execution bit (file mode bit 00020) is unset, and it is a regular file,
|
||||
# some implementations of `ls' use the letter `S', others use `l' or `L'.
|
||||
# Convert this `S'.
|
||||
|
||||
s/[Ll](...)$/S$1/;
|
||||
|
||||
while (/(.)/g) {
|
||||
$mode <<= 1;
|
||||
$mode |= 1 if $1 ne "-" &&
|
||||
$1 ne "*" &&
|
||||
$1 ne 'S' &&
|
||||
$1 ne 'T';
|
||||
}
|
||||
|
||||
$mode |= 0004000 if /^..s....../i;
|
||||
$mode |= 0002000 if /^.....s.../i;
|
||||
$mode |= 0001000 if /^........t/i;
|
||||
|
||||
# De facto standard definitions. From 'stat.h' on Solaris 9.
|
||||
|
||||
$type eq "p" and $mode |= 0010000 or # fifo
|
||||
$type eq "c" and $mode |= 0020000 or # character special
|
||||
$type eq "d" and $mode |= 0040000 or # directory
|
||||
$type eq "b" and $mode |= 0060000 or # block special
|
||||
$type eq "-" and $mode |= 0100000 or # regular
|
||||
$type eq "l" and $mode |= 0120000 or # symbolic link
|
||||
$type eq "s" and $mode |= 0140000 or # socket
|
||||
$type eq "D" and $mode |= 0150000 or # door
|
||||
Carp::croak("Unknown file type: $type");
|
||||
|
||||
$mode;
|
||||
}
|
||||
|
||||
|
||||
sub parse
|
||||
{
|
||||
my($pkg, $dir, $tz, $error) = @_;
|
||||
|
||||
# First let's try to determine what kind of dir parameter we have
|
||||
# received. We allow both listings, reference to arrays and
|
||||
# file handles to read from.
|
||||
|
||||
if (ref($dir) eq 'ARRAY') {
|
||||
# Already split up
|
||||
}
|
||||
elsif (ref($dir) eq 'GLOB') {
|
||||
# A file handle
|
||||
}
|
||||
elsif (ref($dir)) {
|
||||
Carp::croak("Illegal argument to parse_dir()");
|
||||
}
|
||||
elsif ($dir =~ /^\*\w+(::\w+)+$/) {
|
||||
# This scalar looks like a file handle, so we assume it is
|
||||
}
|
||||
else {
|
||||
# A normal scalar listing
|
||||
$dir = [ split(/\n/, $dir) ];
|
||||
}
|
||||
|
||||
$pkg->init();
|
||||
|
||||
my @files = ();
|
||||
if (ref($dir) eq 'ARRAY') {
|
||||
for (@$dir) {
|
||||
push(@files, $pkg->line($_, $tz, $error));
|
||||
}
|
||||
}
|
||||
else {
|
||||
local($_);
|
||||
while (my $line = <$dir>) {
|
||||
chomp $line;
|
||||
push(@files, $pkg->line($line, $tz, $error));
|
||||
}
|
||||
}
|
||||
wantarray ? @files : \@files; ## no critic (Freenode::Wantarray)
|
||||
}
|
||||
|
||||
|
||||
|
||||
package File::Listing::unix;
|
||||
|
||||
use HTTP::Date qw(str2time);
|
||||
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
# A place to remember current directory from last line parsed.
|
||||
our $curdir;
|
||||
|
||||
sub init
|
||||
{
|
||||
$curdir = '';
|
||||
}
|
||||
|
||||
|
||||
sub line
|
||||
{
|
||||
shift; # package name
|
||||
local($_) = shift;
|
||||
my($tz, $error) = @_;
|
||||
|
||||
s/\015//g;
|
||||
#study;
|
||||
|
||||
my ($kind, $size, $date, $name);
|
||||
if (($kind, $size, $date, $name) =
|
||||
/^([\-\*FlrwxsStTdD]{10}) # Type and permission bits
|
||||
.* # Graps
|
||||
\D(\d+) # File size
|
||||
\s+ # Some space
|
||||
(\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}) # Date
|
||||
\s+ # Some more space
|
||||
(.*)$ # File name
|
||||
/x )
|
||||
|
||||
{
|
||||
return if $name eq '.' || $name eq '..';
|
||||
$name = "$curdir/$name" if length $curdir;
|
||||
my $type = '?';
|
||||
if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
|
||||
$name = $1;
|
||||
$type = "l $2";
|
||||
}
|
||||
elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
|
||||
$type = 'f';
|
||||
}
|
||||
elsif ($kind =~ /^[dD]/) {
|
||||
$type = 'd';
|
||||
$size = undef; # Don't believe the reported size
|
||||
}
|
||||
return [$name, $type, $size, str2time($date, $tz),
|
||||
File::Listing::file_mode($kind)];
|
||||
|
||||
}
|
||||
elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
|
||||
my $dir = $1;
|
||||
return () if $dir eq '.';
|
||||
$curdir = $dir;
|
||||
return ();
|
||||
}
|
||||
elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
|
||||
return ();
|
||||
}
|
||||
elsif (/not found/ || # OSF1, HPUX, and SunOS return
|
||||
# "$file not found"
|
||||
/No such file/ || # IRIX returns
|
||||
# "UX:ls: ERROR: Cannot access $file: No such file or directory"
|
||||
# Solaris returns
|
||||
# "$file: No such file or directory"
|
||||
/cannot find/ # Windows NT returns
|
||||
# "The system cannot find the path specified."
|
||||
) {
|
||||
return () unless defined $error;
|
||||
&$error($_) if ref($error) eq 'CODE';
|
||||
warn "Error: $_\n" if $error eq 'warn';
|
||||
return ();
|
||||
}
|
||||
elsif ($_ eq '') { # AIX, and Linux return nothing
|
||||
return () unless defined $error;
|
||||
&$error("No such file or directory") if ref($error) eq 'CODE';
|
||||
warn "Warning: No such file or directory\n" if $error eq 'warn';
|
||||
return ();
|
||||
}
|
||||
else {
|
||||
# parse failed, check if the dosftp parse understands it
|
||||
File::Listing::dosftp->init();
|
||||
return(File::Listing::dosftp->line($_,$tz,$error));
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
package File::Listing::dosftp;
|
||||
|
||||
use HTTP::Date qw(str2time);
|
||||
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
# A place to remember current directory from last line parsed.
|
||||
our $curdir;
|
||||
|
||||
|
||||
|
||||
sub init
|
||||
{
|
||||
$curdir = '';
|
||||
}
|
||||
|
||||
|
||||
sub line
|
||||
{
|
||||
shift; # package name
|
||||
local($_) = shift;
|
||||
my($tz, $error) = @_;
|
||||
|
||||
s/\015//g;
|
||||
|
||||
my ($date, $size_or_dir, $name, $size);
|
||||
|
||||
# 02-05-96 10:48AM 1415 src.slf
|
||||
# 09-10-96 09:18AM <DIR> sl_util
|
||||
if (($date, $size_or_dir, $name) =
|
||||
/^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM) # Date and time info
|
||||
\s+ # Some space
|
||||
(<\w{3}>|\d+) # Dir or Size
|
||||
\s+ # Some more space
|
||||
(.+)$ # File name
|
||||
/x )
|
||||
{
|
||||
return if $name eq '.' || $name eq '..';
|
||||
$name = "$curdir/$name" if length $curdir;
|
||||
my $type = '?';
|
||||
if ($size_or_dir eq '<DIR>') {
|
||||
$type = "d";
|
||||
$size = ""; # directories have no size in the pc listing
|
||||
}
|
||||
else {
|
||||
$type = 'f';
|
||||
$size = $size_or_dir;
|
||||
}
|
||||
return [$name, $type, $size, str2time($date, $tz), undef];
|
||||
}
|
||||
else {
|
||||
return () unless defined $error;
|
||||
&$error($_) if ref($error) eq 'CODE';
|
||||
warn "Can't parse: $_\n" if $error eq 'warn';
|
||||
return ();
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
package File::Listing::vms;
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
package File::Listing::netware;
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
|
||||
|
||||
package File::Listing::apache;
|
||||
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
|
||||
sub init { }
|
||||
|
||||
|
||||
sub line {
|
||||
shift; # package name
|
||||
local($_) = shift;
|
||||
my($tz, $error) = @_; # ignored for now...
|
||||
|
||||
s!</?t[rd][^>]*>! !g; # clean away various table stuff
|
||||
if (m!<A\s+HREF=\"([^?\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
|
||||
my($filename, $filesize) = ($1, $7);
|
||||
my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
|
||||
if ($m =~ /^\d+$/) {
|
||||
($d,$y) = ($y,$d) # iso date
|
||||
}
|
||||
else {
|
||||
$m = _monthabbrev_number($m);
|
||||
}
|
||||
|
||||
$filesize = 0 if $filesize eq '-';
|
||||
if ($filesize =~ s/k$//i) {
|
||||
$filesize *= 1024;
|
||||
}
|
||||
elsif ($filesize =~ s/M$//) {
|
||||
$filesize *= 1024*1024;
|
||||
}
|
||||
elsif ($filesize =~ s/G$//) {
|
||||
$filesize *= 1024*1024*1024;
|
||||
}
|
||||
$filesize = int $filesize;
|
||||
|
||||
require Time::Local;
|
||||
my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y));
|
||||
my $filetype = ($filename =~ s|/$|| ? "d" : "f");
|
||||
return [$filename, $filetype, $filesize, $filetime, undef];
|
||||
}
|
||||
|
||||
# the default listing doesn't include timestamps or file sizes
|
||||
# but we don't want to grab navigation links, so we ignore links
|
||||
# that have a non-trailing slash / character or ?
|
||||
elsif(m!<A\s+HREF=\"([^?/\"]+/?)\">.*</A>!i) {
|
||||
my $filename = $1;
|
||||
my $filetype = ($filename =~ s|/$|| ? "d" : "f");
|
||||
return [$filename, $filetype, undef, undef, undef];
|
||||
}
|
||||
|
||||
return ();
|
||||
}
|
||||
|
||||
|
||||
sub _guess_year {
|
||||
my $y = shift;
|
||||
|
||||
# if the year is already four digit then we shouldn't do
|
||||
# anything to modify it.
|
||||
if ($y >= 1900) {
|
||||
# do nothing
|
||||
|
||||
# TODO: for hysterical er historical reasons we assume 9x is in the
|
||||
# 1990s we should probably not do that, but I don't have any examples
|
||||
# where apache provides two digit dates so I am leaving this as-is
|
||||
# for now. Possibly the right thing is to not handle two digit years.
|
||||
} elsif ($y >= 90) {
|
||||
$y = 1900+$y;
|
||||
}
|
||||
|
||||
# TODO: likewise assuming 00-89 are 20xx is long term probably wrong.
|
||||
elsif ($y < 100) {
|
||||
$y = 2000+$y;
|
||||
}
|
||||
$y;
|
||||
}
|
||||
|
||||
|
||||
sub _monthabbrev_number {
|
||||
my $mon = shift;
|
||||
+{'Jan' => 1,
|
||||
'Feb' => 2,
|
||||
'Mar' => 3,
|
||||
'Apr' => 4,
|
||||
'May' => 5,
|
||||
'Jun' => 6,
|
||||
'Jul' => 7,
|
||||
'Aug' => 8,
|
||||
'Sep' => 9,
|
||||
'Oct' => 10,
|
||||
'Nov' => 11,
|
||||
'Dec' => 12,
|
||||
}->{$mon};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Listing - Parse directory listing
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 6.14
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Listing qw(parse_dir);
|
||||
$ENV{LANG} = "C"; # dates in non-English locales not supported
|
||||
foreach my $file (parse_dir(`ls -l`)) {
|
||||
my ($name, $type, $size, $mtime, $mode) = @$file;
|
||||
next if $type ne 'f'; # plain file
|
||||
#...
|
||||
}
|
||||
|
||||
# directory listing can also be read from a file
|
||||
open my $listing, "zcat ls-lR.gz|";
|
||||
$dir = parse_dir($listing, '+0000');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exports a single function called C<parse_dir>, which can be
|
||||
used to parse directory listings.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 parse_dir
|
||||
|
||||
my $dir = parse_dir( $listing );
|
||||
my $dir = parse_dir( $listing, $time_zone );
|
||||
my $dir = parse_dir( $listing, $time_zone, $type );
|
||||
my $dir = parse_dir( $listing, $time_zone, $type, $error );
|
||||
my @files = parse_dir( $listing );
|
||||
my @files = parse_dir( $listing, $time_zone );
|
||||
my @files = parse_dir( $listing, $time_zone, $type );
|
||||
my @files = parse_dir( $listing, $time_zone, $type, $error );
|
||||
|
||||
The first parameter (C<$listing>) is the directory listing to parse.
|
||||
It can be a scalar, a reference to an array of directory lines or a
|
||||
glob representing a filehandle to read the directory listing from.
|
||||
|
||||
The second parameter (C<$time_zone>) is the time zone to use when
|
||||
parsing time stamps in the listing. If this value is undefined,
|
||||
then the local time zone is assumed.
|
||||
|
||||
The third parameter (C<$type>) is the type of listing to assume.
|
||||
Currently supported formats are C<'unix'>, C<'apache'> and
|
||||
C<'dosftp'>. The default value is C<'unix'>. Ideally, the listing
|
||||
type should be determined automatically.
|
||||
|
||||
The fourth parameter (C<$error>) specifies how unparseable lines
|
||||
should be treated. Values can be C<'ignore'>, C<'warn'> or a code reference.
|
||||
Warn means that the perl warn() function will be called. If a code
|
||||
reference is passed, then this routine will be called and the return
|
||||
value from it will be incorporated in the listing. The default is
|
||||
C<'ignore'>.
|
||||
|
||||
Only the first parameter is mandatory.
|
||||
|
||||
# list context
|
||||
foreach my $file (parse_dir($listing)) {
|
||||
my($name, $type, $size, $mtime, $mode) = @$file;
|
||||
}
|
||||
|
||||
# scalar context
|
||||
my $dir = parse_dir($listing);
|
||||
foreach my $file (@$dir) {
|
||||
my($name, $type, $size, $mtime, $mode) = @$file;
|
||||
}
|
||||
|
||||
The return value from parse_dir() is a list of directory entries.
|
||||
In a scalar context the return value is a reference to the list.
|
||||
The directory entries are represented by an array consisting of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
The name of the file.
|
||||
|
||||
=item type
|
||||
|
||||
One of: C<f> file, C<d> directory, C<l> symlink, C<?> unknown.
|
||||
|
||||
=item size
|
||||
|
||||
The size of the file.
|
||||
|
||||
=item time
|
||||
|
||||
The number of seconds since January 1, 1970.
|
||||
|
||||
=item mode
|
||||
|
||||
Bitmask a la the mode returned by C<stat>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<File::Listing::Ftpcopy>
|
||||
|
||||
Provides the same interface but uses XS and the parser implementation from C<ftpcopy>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Original author: Gisle Aas
|
||||
|
||||
Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Adam Kennedy
|
||||
|
||||
Adam Sjogren
|
||||
|
||||
Alex Kapranoff
|
||||
|
||||
Alexey Tourbin
|
||||
|
||||
Andreas J. Koenig
|
||||
|
||||
Bill Mann
|
||||
|
||||
Bron Gondwana
|
||||
|
||||
DAVIDRW
|
||||
|
||||
Daniel Hedlund
|
||||
|
||||
David E. Wheeler
|
||||
|
||||
David Steinbrunner
|
||||
|
||||
Erik Esterer
|
||||
|
||||
FWILES
|
||||
|
||||
Father Chrysostomos
|
||||
|
||||
Gavin Peters
|
||||
|
||||
Graeme Thompson
|
||||
|
||||
Hans-H. Froehlich
|
||||
|
||||
Ian Kilgore
|
||||
|
||||
Jacob J
|
||||
|
||||
Mark Stosberg
|
||||
|
||||
Mike Schilli
|
||||
|
||||
Ondrej Hanak
|
||||
|
||||
Peter John Acklam
|
||||
|
||||
Peter Rabbitson
|
||||
|
||||
Robert Stone
|
||||
|
||||
Rolf Grossmann
|
||||
|
||||
Sean M. Burke
|
||||
|
||||
Simon Legner
|
||||
|
||||
Slaven Rezic
|
||||
|
||||
Spiros Denaxas
|
||||
|
||||
Steve Hay
|
||||
|
||||
Todd Lipcon
|
||||
|
||||
Tom Hukins
|
||||
|
||||
Tony Finch
|
||||
|
||||
Toru Yamaguchi
|
||||
|
||||
Ville Skyttä
|
||||
|
||||
Yuri Karaban
|
||||
|
||||
Zefram
|
||||
|
||||
amire80
|
||||
|
||||
jefflee
|
||||
|
||||
john9art
|
||||
|
||||
mschilli
|
||||
|
||||
murphy
|
||||
|
||||
phrstbrn
|
||||
|
||||
ruff
|
||||
|
||||
sasao
|
||||
|
||||
uid39246
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 1996-2020 by Gisle Aas.
|
||||
|
||||
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
|
||||
442
database/perl/vendor/lib/File/Map.pm
vendored
Normal file
442
database/perl/vendor/lib/File/Map.pm
vendored
Normal file
@@ -0,0 +1,442 @@
|
||||
package File::Map;
|
||||
$File::Map::VERSION = '0.67';
|
||||
# This software is copyright (c) 2008, 2009, 2010, 2011, 2012 by Leon Timmermans <leont@cpan.org>.
|
||||
#
|
||||
# This is free software; you can redistribute it and/or modify it under
|
||||
# the same terms as perl itself.
|
||||
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use subs qw{PROT_READ PROT_WRITE MAP_PRIVATE MAP_SHARED MAP_FILE MAP_ANONYMOUS};
|
||||
|
||||
use Sub::Exporter::Progressive 0.001005 ();
|
||||
use XSLoader ();
|
||||
use Carp qw/croak carp/;
|
||||
use PerlIO::Layers qw/query_handle/;
|
||||
|
||||
XSLoader::load('File::Map', File::Map->VERSION);
|
||||
|
||||
my %export_data = (
|
||||
'map' => [qw/map_handle map_file map_anonymous unmap sys_map/],
|
||||
extra => [qw/remap sync pin unpin advise protect/],
|
||||
'lock' => [qw/wait_until notify broadcast lock_map/],
|
||||
constants => [qw/PROT_NONE PROT_READ PROT_WRITE PROT_EXEC MAP_ANONYMOUS MAP_SHARED MAP_PRIVATE MAP_ANON MAP_FILE/]
|
||||
);
|
||||
|
||||
{
|
||||
my (@export_ok, %export_tags);
|
||||
|
||||
while (my ($category, $functions) = each %export_data) {
|
||||
for my $function (grep { defined &{$_} } @{$functions}) {
|
||||
push @export_ok, $function;
|
||||
push @{ $export_tags{$category} }, $function;
|
||||
}
|
||||
}
|
||||
|
||||
Sub::Exporter::Progressive->import(-setup => { exports => \@export_ok, groups => \%export_tags });
|
||||
}
|
||||
|
||||
my $anon_fh = -1;
|
||||
|
||||
sub _check_layers {
|
||||
my $fh = shift;
|
||||
croak "Can't map fake filehandle" if fileno $fh < 0;
|
||||
if (warnings::enabled('layer')) {
|
||||
carp "Shouldn't map non-binary filehandle" if not query_handle($fh, 'mappable');
|
||||
}
|
||||
return query_handle($fh, 'utf8');
|
||||
}
|
||||
|
||||
sub _get_offset_length {
|
||||
my ($offset, $length, $fh) = @_;
|
||||
|
||||
my $size = -s $fh;
|
||||
$offset ||= 0;
|
||||
$length ||= $size - $offset;
|
||||
my $end = $offset + $length;
|
||||
croak "Window ($offset,$end) is outside the file" if $offset < 0 or $end > $size and not -c _;
|
||||
return ($offset, $length);
|
||||
}
|
||||
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
|
||||
sub map_handle {
|
||||
my (undef, $fh, $mode, $offset, $length) = @_;
|
||||
my $utf8 = _check_layers($fh);
|
||||
($offset, $length) = _get_offset_length($offset, $length, $fh);
|
||||
_mmap_impl($_[0], $length, _protection_value($mode || '<'), MAP_SHARED | MAP_FILE, fileno $fh, $offset, $utf8);
|
||||
return;
|
||||
}
|
||||
|
||||
sub map_file {
|
||||
my (undef, $filename, $mode, $offset, $length) = @_;
|
||||
$mode ||= '<';
|
||||
my ($minimode, $encoding) = $mode =~ / \A ([^:]+) ([:\w-]+)? \z /xms;
|
||||
$encoding = ':raw' if not defined $encoding;
|
||||
open my $fh, $minimode.$encoding, $filename or croak "Couldn't open file $filename: $!";
|
||||
my $utf8 = _check_layers($fh);
|
||||
($offset, $length) = _get_offset_length($offset, $length, $fh);
|
||||
_mmap_impl($_[0], $length, _protection_value($minimode), MAP_SHARED | MAP_FILE, fileno $fh, $offset, $utf8);
|
||||
close $fh or croak "Couldn't close $filename after mapping: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
my %flag_for = (
|
||||
private => MAP_PRIVATE,
|
||||
shared => MAP_SHARED,
|
||||
);
|
||||
sub map_anonymous {
|
||||
my (undef, $length, $flag_name) = @_;
|
||||
my $flag = $flag_for{ $flag_name || 'shared' };
|
||||
croak "No such flag '$flag_name'" if not defined $flag;
|
||||
croak 'Zero length specified for anonymous map' if $length == 0;
|
||||
_mmap_impl($_[0], $length, PROT_READ | PROT_WRITE, MAP_ANONYMOUS | $flag, $anon_fh, 0);
|
||||
return;
|
||||
}
|
||||
|
||||
sub sys_map { ## no critic (ProhibitManyArgs)
|
||||
my (undef, $length, $protection, $flags, $fh, $offset) = @_;
|
||||
my $utf8 = _check_layers($fh);
|
||||
my $fd = ($flags & MAP_ANONYMOUS) ? $anon_fh : fileno $fh;
|
||||
$offset ||= 0;
|
||||
_mmap_impl($_[0], $length, $protection, $flags, $fd, $offset, $utf8);
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
#ABSTRACT: Memory mapping made simple and safe.
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Map - Memory mapping made simple and safe.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.67
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Map 'map_file';
|
||||
|
||||
map_file my $map, $filename, '+<';
|
||||
$map =~ s/bar/quz/g;
|
||||
substr $map, 1024, 11, "Hello world";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
File::Map maps files or anonymous memory into perl variables.
|
||||
|
||||
=head2 Advantages of memory mapping
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Unlike normal perl variables, mapped memory is (usually) shared between threads or forked processes.
|
||||
|
||||
=item * It is an efficient way to slurp an entire file. Unlike for example L<File::Slurp>, this module returns almost immediately, loading the pages lazily on access. This means you only 'pay' for the parts of the file you actually use.
|
||||
|
||||
=item * Perl usually doesn't return memory to the system while running, mapped memory can be returned.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Advantages of this module over other similar modules
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Safety and Speed
|
||||
|
||||
This module is safe yet fast. Alternatives are either fast but can cause segfaults or lose the mapping when not used correctly, or are safe but rather slow. File::Map is as fast as a normal string yet safe.
|
||||
|
||||
=item * Simplicity
|
||||
|
||||
It offers a simple interface targeted at common usage patterns
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Files are mapped into a variable that can be read just like any other variable, and it can be written to using standard Perl techniques such as regexps and C<substr>.
|
||||
|
||||
=item * Files can be mapped using a set of simple functions. There is no need to know weird constants or the order of 6 arguments.
|
||||
|
||||
=item * It will automatically unmap the file when the scalar gets destroyed. This works correctly even in multi-threaded programs.
|
||||
|
||||
=back
|
||||
|
||||
=item * Portability
|
||||
|
||||
File::Map supports Unix and Windows.
|
||||
|
||||
=item * Thread synchronization
|
||||
|
||||
It has built-in support for thread synchronization.
|
||||
|
||||
=back
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 Mapping
|
||||
|
||||
The following functions for mapping a variable are available for exportation. Note that all of these functions throw exceptions on errors, unless noted otherwise.
|
||||
|
||||
=head3 map_handle $lvalue, $filehandle, $mode = '<', $offset = 0, $length = -s(*handle) - $offset
|
||||
|
||||
Use a filehandle to map into an lvalue. $filehandle should be a scalar filehandle. $mode uses the same format as C<open> does (it currently accepts C<< < >>, C<< +< >>, C<< > >> and C<< +> >>). $offset and $length are byte positions in the file, and default to mapping the whole file.
|
||||
|
||||
=head3 * map_file $lvalue, $filename, $mode = '<', $offset = 0, $length = -s($filename) - $offset
|
||||
|
||||
Open a file and map it into an lvalue. Other than $filename, all arguments work as in map_handle.
|
||||
|
||||
=head3 * map_anonymous $lvalue, $length, $type
|
||||
|
||||
Map an anonymous piece of memory. $type can be either C<'shared'>, in which case it will be shared with child processes, or C<'private'>, which won't be shared.
|
||||
|
||||
=head3 * sys_map $lvalue, $length, $protection, $flags, $filehandle, $offset = 0
|
||||
|
||||
Low level map operation. It accepts the same constants as mmap does (except its first argument obviously). If you don't know how mmap works you probably shouldn't be using this.
|
||||
|
||||
=head3 * unmap $lvalue
|
||||
|
||||
Unmap a variable. Note that normally this is not necessary as variables are unmapped automatically at destruction, but it is included for completeness.
|
||||
|
||||
=head3 * remap $lvalue, $new_size
|
||||
|
||||
Try to remap $lvalue to a new size. This call is linux specific and not supported on other systems. For a file backed mapping a file must be long enough to hold the new size, otherwise you can expect bus faults. For an anonymous map it must be private, shared maps can not be remapped. B<Use with caution>.
|
||||
|
||||
=head2 Auxiliary
|
||||
|
||||
=head3 * sync $lvalue, $synchronous = 1
|
||||
|
||||
Flush changes made to the memory map back to disk. Mappings are always flushed when unmapped, so this is usually not necessary. If $synchronous is true and your operating system supports it, the flushing will be done synchronously.
|
||||
|
||||
=head3 * pin $lvalue
|
||||
|
||||
Disable paging for this map, thus locking it in physical memory. Depending on your operating system there may be limits on pinning.
|
||||
|
||||
=head3 * unpin $lvalue
|
||||
|
||||
Unlock the map from physical memory.
|
||||
|
||||
=head3 * advise $lvalue, $advice
|
||||
|
||||
Advise a certain memory usage pattern. This is not implemented on all operating systems, and may be a no-op. The following values for $advice are always accepted:.
|
||||
|
||||
=over 2
|
||||
|
||||
=item * normal
|
||||
|
||||
Specifies that the application has no advice to give on its behavior with respect to the mapped variable. It is the default characteristic if no advice is given.
|
||||
|
||||
=item * random
|
||||
|
||||
Specifies that the application expects to access the mapped variable in a random order.
|
||||
|
||||
=item * sequential
|
||||
|
||||
Specifies that the application expects to access the mapped variable sequentially from start to end.
|
||||
|
||||
=item * willneed
|
||||
|
||||
Specifies that the application expects to access the mapped variable in the near future.
|
||||
|
||||
=item * dontneed
|
||||
|
||||
Specifies that the application expects that it will not access the mapped variable in the near future.
|
||||
|
||||
=back
|
||||
|
||||
On some systems there may be more values available, but this can not be relied on. Unknown values for $advice will cause a warning but are further ignored.
|
||||
|
||||
=head3 * protect $lvalue, $mode
|
||||
|
||||
Change the memory protection of the mapping. $mode takes the same format as C<open>, but also accepts sys_map style constants.
|
||||
|
||||
=head2 Locking
|
||||
|
||||
These locking functions provide locking for threads for the mapped region. The mapped region has an internal lock and condition variable. The condition variable functions(C<wait_until>, C<notify>, C<broadcast>) can only be used inside a locked block. If your perl has been compiled without thread support the condition functions will not be available.
|
||||
|
||||
=head3 * lock_map $lvalue
|
||||
|
||||
Lock $lvalue until the end of the scope. If your perl does not support threads, this will be a no-op.
|
||||
|
||||
=head3 * wait_until { block } $lvalue
|
||||
|
||||
Wait for block to become true. After every failed attempt, wait for a signal. It returns the value returned by the block.
|
||||
|
||||
=head3 * notify $lvalue
|
||||
|
||||
This will signal to one listener that the map is available.
|
||||
|
||||
=head3 * broadcast $lvalue
|
||||
|
||||
This will signal to all listeners that the map is available.
|
||||
|
||||
=head2 Constants
|
||||
|
||||
=over 4
|
||||
|
||||
=item PROT_NONE, PROT_READ, PROT_WRITE, PROT_EXEC, MAP_ANONYMOUS, MAP_SHARED, MAP_PRIVATE, MAP_ANON, MAP_FILE
|
||||
|
||||
These constants are used for sys_map. If you think you need them your mmap manpage will explain them, but in most cases you can skip sys_map altogether.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All previously mentioned functions are available for exportation, but none are exported by default. Some functions may not be available on your OS or your version of perl as specified above. A number of tags are defined to make importation easier.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * :map
|
||||
|
||||
map_handle, map_file, map_anonymous, sys_map, unmap
|
||||
|
||||
=item * :extra
|
||||
|
||||
remap, sync, pin, unpin, advise, protect
|
||||
|
||||
=item * :lock
|
||||
|
||||
lock_map, wait_until, notify, broadcast
|
||||
|
||||
=item * :constants
|
||||
|
||||
PROT_NONE, PROT_READ, PROT_WRITE, PROT_EXEC, MAP_ANONYMOUS, MAP_SHARED, MAP_PRIVATE, MAP_ANON, MAP_FILE
|
||||
|
||||
=item * :all
|
||||
|
||||
All functions defined in this module.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=head2 Exceptions
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Could not <function name>: this variable is not memory mapped
|
||||
|
||||
An attempt was made to C<sync>, C<remap>, C<unmap>, C<pin>, C<unpin>, C<advise> or C<lock_map> an unmapped variable.
|
||||
|
||||
=item * Could not <function name>: <system error>
|
||||
|
||||
Your OS didn't allow File::Map to do what you asked it to do for some reason.
|
||||
|
||||
=item * Trying to <function_name> on an unlocked map
|
||||
|
||||
You tried to C<wait_until>, C<notify> or C<broadcast> on an unlocked variable.
|
||||
|
||||
=item * Zero length not allowed for anonymous map
|
||||
|
||||
A zero length anonymous map is not possible (or in any way useful).
|
||||
|
||||
=item * Can't remap a shared mapping
|
||||
|
||||
An attempt was made to remap a mapping that is shared among different threads, this is not possible.
|
||||
|
||||
=item * Window (<start>, <end>) is outside the file
|
||||
|
||||
The offset and/or length you specified were invalid for this file.
|
||||
|
||||
=item * Can't map fake filehandle
|
||||
|
||||
The filehandle you provided is not real. This may mean it's a scalar string handle or a tied handle.
|
||||
|
||||
=item * No such flag <flag_name>
|
||||
|
||||
The flag given for map_anonymous isn't valid, it should either be C<shared> or C<private>.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Warnings
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Writing directly to a memory mapped file is not recommended
|
||||
|
||||
Due to the way perl works internally, it's not possible to write a mapping implementation that allows direct assignment yet performs well. As a compromise, File::Map is capable of fixing up the mess if you do it nonetheless, but it will warn you that you're doing something you shouldn't. This warning is only given when C<use warnings 'substr'> is in effect.
|
||||
|
||||
=item * Truncating new value to size of the memory map
|
||||
|
||||
This warning is additional to the previous one, warning you that you're losing data. This warning is only given when C<use warnings 'substr'> is in effect.
|
||||
|
||||
=item * Shouldn't mmap non-binary filehandle
|
||||
|
||||
You tried to to map a filehandle that has some encoding layer. Encoding layers are not supported by File::Map. This warning is only given when C<use warnings 'layer'> is in effect. Note that this may become an exception in a future version.
|
||||
|
||||
=item * Unknown advice '<advice>'
|
||||
|
||||
You gave advise an advice it didn't know. This is either a typo or a portability issue. This warning is only given when C<use warnings 'portable'> is in effect.
|
||||
|
||||
=item * Syncing a readonly map makes no sense
|
||||
|
||||
C<sync> flushes changes to the map to the filesystem. This obviously is of little use when you can't change the map. This warning is only given when C<use warnings 'io'> is in effect.
|
||||
|
||||
=item * Can't overwrite an empty map
|
||||
|
||||
Overwriting an empty map is rather nonsensical, hence a warning is given when this is tried. This warning is only given when C<use warnings 'substr'> is in effect.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
This module depends on perl 5.8, L<Sub::Exporter::Progressive> and L<PerlIO::Layers>. Perl 5.8.8 or higher is recommended because older versions can give spurious warnings.
|
||||
|
||||
In perl versions before 5.11.5 many string functions including C<substr> are limited to L<32bit logic|http://rt.perl.org/rt3//Public/Bug/Display.html?id=72784>, even on 64bit architectures. Effectively this means you can't use them on strings bigger than 2GB. If you are working with such large files, it is strongly recommended to upgrade to 5.12.
|
||||
|
||||
In perl versions before 5.17.5, there is an off-by-one bug in Perl's regexp engine, as explained L<here|http://rt.perl.org/rt3//Public/Bug/Display.html?id=73542>. If the length of the file is an exact multiple of the page size, some regexps can trigger a segmentation fault.
|
||||
|
||||
=head1 PITFALLS
|
||||
|
||||
=over 4
|
||||
|
||||
=item * This module doesn't do any encoding or newline transformation for you, and will reject any filehandle with such features enabled as mapping it would return a different value than reading it normally. Most importantly this means that on Windows you have to remember to use the C<:raw> open mode or L<binmode> to make your filehandles binary before mapping them, as by default it would do C<crlf> transformation. See L<PerlIO> for more information on how that works.
|
||||
|
||||
=item * You can map a C<:utf8> filehandle, but writing to it may be tricky. Hic sunt dracones.
|
||||
|
||||
=item * You probably don't want to use C<E<gt>> as a mode. This does not give you reading permissions on many architectures, resulting in segmentation faults when trying to read a variable (confusingly, it will work on some others like x86).
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
As any piece of software, bugs are likely to exist here. Bug reports are welcome.
|
||||
|
||||
Please report any bugs or feature requests to C<bug-file-map at rt.cpan.org>, or through
|
||||
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Map>. I will be notified, and then you'll
|
||||
automatically be notified of progress on your bug as I make changes.
|
||||
|
||||
Unicode file mappings are known to be buggy on perl 5.8.7 and lower.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item * L<Sys::Mmap>, the original Perl mmap module
|
||||
|
||||
=item * L<mmap(2)>, your mmap man page
|
||||
|
||||
=item * L<Win32::MMF>
|
||||
|
||||
=item * CreateFileMapping at MSDN: L<http://msdn.microsoft.com/en-us/library/aa366537(VS.85).aspx>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Leon Timmermans <fawaka@gmail.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2008 by Leon Timmermans.
|
||||
|
||||
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
|
||||
566
database/perl/vendor/lib/File/Remove.pm
vendored
Normal file
566
database/perl/vendor/lib/File/Remove.pm
vendored
Normal file
@@ -0,0 +1,566 @@
|
||||
package File::Remove;
|
||||
$File::Remove::VERSION = '1.60';
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use vars qw{ @ISA @EXPORT_OK };
|
||||
use vars qw{ $DEBUG $unlink $rmdir };
|
||||
|
||||
BEGIN
|
||||
{
|
||||
@ISA = qw{ Exporter };
|
||||
@EXPORT_OK = qw{ remove rm clear trash };
|
||||
}
|
||||
|
||||
use File::Path ();
|
||||
use File::Glob ();
|
||||
use File::Spec 3.29 ();
|
||||
use Cwd 3.29 ();
|
||||
|
||||
# $debug variable must be set before loading File::Remove.
|
||||
# Convert to a constant to allow debugging code to be pruned out.
|
||||
use constant DEBUG => !!$DEBUG;
|
||||
|
||||
# Are we on VMS?
|
||||
# If so copy File::Path and assume VMS::Filespec is loaded
|
||||
use constant IS_VMS => !!( $^O eq 'VMS' );
|
||||
|
||||
# Are we on Mac?
|
||||
# If so we'll need to do some special trash work
|
||||
use constant IS_MAC => !!( $^O eq 'darwin' );
|
||||
|
||||
# Are we on Win32?
|
||||
# If so write permissions does not imply deletion permissions
|
||||
use constant IS_WIN32 => !!( $^O =~ /^MSWin/ or $^O eq 'cygwin' );
|
||||
|
||||
# If we ever need a Mac::Glue object we will want to cache it.
|
||||
my $glue;
|
||||
|
||||
#####################################################################
|
||||
# Main Functions
|
||||
|
||||
my @CLEANUP = ();
|
||||
|
||||
## no critic
|
||||
sub clear (@)
|
||||
{
|
||||
my @files = expand(@_);
|
||||
|
||||
# Do the initial deletion
|
||||
foreach my $file (@files)
|
||||
{
|
||||
next unless -e $file;
|
||||
remove( \1, $file );
|
||||
}
|
||||
|
||||
# Delete again at END-time.
|
||||
# Save the current PID so that forked children
|
||||
# won't delete things that the parent expects to
|
||||
# live until their end-time.
|
||||
push @CLEANUP, map { [ $$, $_ ] } @files;
|
||||
}
|
||||
## use critic
|
||||
|
||||
END
|
||||
{
|
||||
foreach my $file (@CLEANUP)
|
||||
{
|
||||
next unless $file->[0] == $$;
|
||||
next unless -e $file->[1];
|
||||
remove( \1, $file->[1] );
|
||||
}
|
||||
}
|
||||
|
||||
# Acts like unlink would until given a directory as an argument, then
|
||||
# it acts like rm -rf ;) unless the recursive arg is zero which it is by
|
||||
# default
|
||||
## no critic
|
||||
sub remove (@)
|
||||
{
|
||||
## use critic
|
||||
my $recursive = ( ref $_[0] eq 'SCALAR' ) ? shift : \0;
|
||||
my $opts = ( ref $_[0] eq 'HASH' ) ? shift : { glob => 1 };
|
||||
my @files = _expand_with_opts( $opts, @_ );
|
||||
|
||||
# Iterate over the files
|
||||
my @removes;
|
||||
foreach my $path (@files)
|
||||
{
|
||||
# need to check for symlink first
|
||||
# could be pointing to nonexisting/non-readable destination
|
||||
if ( -l $path )
|
||||
{
|
||||
print "link: $path\n" if DEBUG;
|
||||
if ( $unlink ? $unlink->($path) : unlink($path) )
|
||||
{
|
||||
push @removes, $path;
|
||||
}
|
||||
next;
|
||||
}
|
||||
unless ( -e $path )
|
||||
{
|
||||
print "missing: $path\n" if DEBUG;
|
||||
push @removes, $path; # Say we deleted it
|
||||
next;
|
||||
}
|
||||
my $can_delete;
|
||||
if (IS_VMS)
|
||||
{
|
||||
$can_delete = VMS::Filespec::candelete($path);
|
||||
}
|
||||
elsif (IS_WIN32)
|
||||
{
|
||||
# Assume we can delete it for the moment
|
||||
$can_delete = 1;
|
||||
}
|
||||
elsif ( -w $path )
|
||||
{
|
||||
# We have write permissions already
|
||||
$can_delete = 1;
|
||||
}
|
||||
elsif ( $< == 0 )
|
||||
{
|
||||
# Unixy and root
|
||||
$can_delete = 1;
|
||||
}
|
||||
elsif ( ( lstat($path) )[4] == $< )
|
||||
{
|
||||
# I own the file
|
||||
$can_delete = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
# I don't think we can delete it
|
||||
$can_delete = 0;
|
||||
}
|
||||
unless ($can_delete)
|
||||
{
|
||||
print "nowrite: $path\n" if DEBUG;
|
||||
next;
|
||||
}
|
||||
|
||||
if ( -f $path )
|
||||
{
|
||||
print "file: $path\n" if DEBUG;
|
||||
unless ( -w $path )
|
||||
{
|
||||
# Make the file writable (implementation from File::Path)
|
||||
( undef, undef, my $rp ) = lstat $path or next;
|
||||
$rp &= 07777; # Don't forget setuid, setgid, sticky bits
|
||||
$rp |= 0600; # Turn on user read/write
|
||||
chmod $rp, $path;
|
||||
}
|
||||
if ( $unlink ? $unlink->($path) : unlink($path) )
|
||||
{
|
||||
# Failed to delete the file
|
||||
next if -e $path;
|
||||
push @removes, $path;
|
||||
}
|
||||
|
||||
}
|
||||
elsif ( -d $path )
|
||||
{
|
||||
print "dir: $path\n" if DEBUG;
|
||||
my $dir = File::Spec->canonpath($path);
|
||||
|
||||
# Do we need to move our cwd out of the location
|
||||
# we are planning to delete?
|
||||
my $chdir = _moveto($dir);
|
||||
if ( length $chdir )
|
||||
{
|
||||
chdir($chdir) or next;
|
||||
}
|
||||
|
||||
if ($$recursive)
|
||||
{
|
||||
if ( File::Path::rmtree( [$dir], DEBUG, 0 ) )
|
||||
{
|
||||
# Failed to delete the directory
|
||||
next if -e $path;
|
||||
push @removes, $path;
|
||||
}
|
||||
|
||||
}
|
||||
else
|
||||
{
|
||||
my ($save_mode) = ( stat $dir )[2];
|
||||
chmod $save_mode & 0777,
|
||||
$dir; # just in case we cannot remove it.
|
||||
if ( $rmdir ? $rmdir->($dir) : rmdir($dir) )
|
||||
{
|
||||
# Failed to delete the directory
|
||||
next if -e $path;
|
||||
push @removes, $path;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
else
|
||||
{
|
||||
print "???: $path\n" if DEBUG;
|
||||
}
|
||||
}
|
||||
|
||||
return @removes;
|
||||
}
|
||||
|
||||
sub rm (@)
|
||||
{
|
||||
goto &remove;
|
||||
}
|
||||
|
||||
sub trash (@)
|
||||
{
|
||||
local $unlink = $unlink;
|
||||
local $rmdir = $rmdir;
|
||||
|
||||
if ( ref $_[0] eq 'HASH' )
|
||||
{
|
||||
my %options = %{ +shift @_ };
|
||||
$unlink = $options{unlink};
|
||||
$rmdir = $options{rmdir};
|
||||
|
||||
}
|
||||
elsif (IS_WIN32)
|
||||
{
|
||||
local $@;
|
||||
eval 'use Win32::FileOp ();';
|
||||
die "Can't load Win32::FileOp to support the Recycle Bin: \$@ = $@"
|
||||
if length $@;
|
||||
$unlink = \&Win32::FileOp::Recycle;
|
||||
$rmdir = \&Win32::FileOp::Recycle;
|
||||
|
||||
}
|
||||
elsif (IS_MAC)
|
||||
{
|
||||
unless ($glue)
|
||||
{
|
||||
local $@;
|
||||
eval 'use Mac::Glue ();';
|
||||
die
|
||||
"Can't load Mac::Glue::Finder to support the Trash Can: \$@ = $@"
|
||||
if length $@;
|
||||
$glue = Mac::Glue->new('Finder');
|
||||
}
|
||||
my $code = sub {
|
||||
my @files =
|
||||
map { Mac::Glue::param_type( Mac::Glue::typeAlias() => $_ ) }
|
||||
@_;
|
||||
$glue->delete( \@files );
|
||||
};
|
||||
$unlink = $code;
|
||||
$rmdir = $code;
|
||||
}
|
||||
else
|
||||
{
|
||||
die
|
||||
"Support for trash() on platform '$^O' not available at this time.\n";
|
||||
}
|
||||
|
||||
remove(@_);
|
||||
}
|
||||
|
||||
sub undelete (@)
|
||||
{
|
||||
goto &trash;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Support Functions
|
||||
|
||||
sub _expand_with_opts
|
||||
{
|
||||
my $opts = shift;
|
||||
return ( $opts->{glob} ? expand(@_) : @_ );
|
||||
}
|
||||
|
||||
sub expand (@)
|
||||
{
|
||||
map { -e $_ ? $_ : File::Glob::bsd_glob($_) } @_;
|
||||
}
|
||||
|
||||
# Do we need to move to a different directory to delete a directory,
|
||||
# and if so which.
|
||||
sub _moveto
|
||||
{
|
||||
my $remove = File::Spec->rel2abs(shift);
|
||||
my $cwd = @_ ? shift : Cwd::cwd();
|
||||
|
||||
# Do everything in absolute terms
|
||||
$remove = Cwd::abs_path($remove);
|
||||
$cwd = Cwd::abs_path($cwd);
|
||||
|
||||
# If we are on a different volume we don't need to move
|
||||
my ( $cv, $cd ) = File::Spec->splitpath( $cwd, 1 );
|
||||
my ( $rv, $rd ) = File::Spec->splitpath( $remove, 1 );
|
||||
return '' unless $cv eq $rv;
|
||||
|
||||
# If we have to move, it's to one level above the deletion
|
||||
my @cd = File::Spec->splitdir($cd);
|
||||
my @rd = File::Spec->splitdir($rd);
|
||||
|
||||
# Is the current directory the same as or inside the remove directory?
|
||||
unless ( @cd >= @rd )
|
||||
{
|
||||
return '';
|
||||
}
|
||||
foreach ( 0 .. $#rd )
|
||||
{
|
||||
$cd[$_] eq $rd[$_] or return '';
|
||||
}
|
||||
|
||||
# Confirmed, the current working dir is in the removal dir
|
||||
pop @rd;
|
||||
return File::Spec->catpath( $rv, File::Spec->catdir(@rd), '' );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Remove - Remove files and directories
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.60
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Remove 'remove';
|
||||
|
||||
# removes (without recursion) several files
|
||||
remove( '*.c', '*.pl' );
|
||||
|
||||
# removes (with recursion) several directories
|
||||
remove( \1, qw{directory1 directory2} );
|
||||
|
||||
# removes (with recursion) several files and directories
|
||||
remove( \1, qw{file1 file2 directory1 *~} );
|
||||
|
||||
# removes without globbing:
|
||||
remove( \1, {glob => 0}, '*');
|
||||
|
||||
# trashes (with support for undeleting later) several files
|
||||
trash( '*~' );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<File::Remove::remove> removes files and directories. It acts like
|
||||
B</bin/rm>, for the most part. Although C<unlink> can be given a list
|
||||
of files, it will not remove directories; this module remedies that.
|
||||
It also accepts wildcards, * and ?, as arguments for filenames.
|
||||
|
||||
B<File::Remove::trash> accepts the same arguments as B<remove>, with
|
||||
the addition of an optional, infrequently used "other platforms"
|
||||
hashref.
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=head2 remove
|
||||
|
||||
Removes files and directories. Directories are removed recursively like
|
||||
in B<rm -rf> if the first argument is a reference to a scalar that
|
||||
evaluates to true. If the first argument is a reference to a scalar,
|
||||
then it is used as the value of the recursive flag. By default it's
|
||||
false so only pass \1 to it.
|
||||
|
||||
If the next argument is a hash reference then it is a key/values of options.
|
||||
Currently, there is one supported option of C<<< 'glob' => 0 >>> which prevents
|
||||
globbing. E.g:
|
||||
|
||||
remove(\1, {glob => 0}, '*');
|
||||
|
||||
Will not remove files globbed by '*' and will only remove the file
|
||||
called asterisk if it exists.
|
||||
|
||||
In list context it returns a list of files/directories removed, in
|
||||
scalar context it returns the number of files/directories removed. The
|
||||
list/number should match what was passed in if everything went well.
|
||||
|
||||
=head2 rm
|
||||
|
||||
Just calls B<remove>. It's there for people who get tired of typing
|
||||
B<remove>.
|
||||
|
||||
=head2 clear
|
||||
|
||||
The C<clear> function is a version of C<remove> designed for
|
||||
use in test scripts. It takes a list of paths that it will both
|
||||
initially delete during the current test run, and then further
|
||||
flag for deletion at END-time as a convenience for the next test
|
||||
run.
|
||||
|
||||
=head2 trash
|
||||
|
||||
Removes files and directories, with support for undeleting later.
|
||||
Accepts an optional "other platforms" hashref, passing the remaining
|
||||
arguments to B<remove>.
|
||||
|
||||
=over 4
|
||||
|
||||
=item Win32
|
||||
|
||||
Requires L<Win32::FileOp>.
|
||||
|
||||
Installation not actually enforced on Win32 yet, since L<Win32::FileOp>
|
||||
has badly failing dependencies at time of writing.
|
||||
|
||||
=item OS X
|
||||
|
||||
Requires L<Mac::Glue>.
|
||||
|
||||
=item Other platforms
|
||||
|
||||
The first argument to trash() must be a hashref with two keys,
|
||||
'rmdir' and 'unlink', each referencing a coderef. The coderefs
|
||||
will be called with the filenames that are to be deleted.
|
||||
|
||||
=back
|
||||
|
||||
=head2 expand
|
||||
|
||||
B<DO NOT USE.> Kept for legacy.
|
||||
|
||||
=head2 undelete
|
||||
|
||||
B<DO NOT USE.> Kept for legacy.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs should always be submitted via the CPAN bug tracker
|
||||
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Remove>
|
||||
|
||||
For other issues, contact the maintainer.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Taken over by Shlomi Fish (L<http://www.shlomifish.org/>) while disclaiming
|
||||
all rights and placing his modifications under
|
||||
CC0/public-domain/MIT/any-other-licence.
|
||||
|
||||
Some parts copyright 2006 - 2012 Adam Kennedy.
|
||||
|
||||
Taken over by Adam Kennedy E<lt>adamk@cpan.orgE<gt> to fix the
|
||||
"deep readonly files" bug, and do some package cleaning.
|
||||
|
||||
Some parts copyright 2004 - 2005 Richard Soderberg.
|
||||
|
||||
Taken over by Richard Soderberg E<lt>perl@crystalflame.netE<gt> to
|
||||
port it to L<File::Spec> and add tests.
|
||||
|
||||
Original copyright: 1998 by Gabor Egressy, E<lt>gabor@vmunix.comE<gt>.
|
||||
|
||||
This program is free software; you can redistribute and/or modify it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Websites
|
||||
|
||||
The following websites have more information about this module, and may be of help to you. As always,
|
||||
in addition to those websites please use your favorite search engine to discover more resources.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
MetaCPAN
|
||||
|
||||
A modern, open-source CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<https://metacpan.org/release/File-Remove>
|
||||
|
||||
=item *
|
||||
|
||||
RT: CPAN's Bug Tracker
|
||||
|
||||
The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN.
|
||||
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=File-Remove>
|
||||
|
||||
=item *
|
||||
|
||||
CPANTS
|
||||
|
||||
The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
|
||||
|
||||
L<http://cpants.cpanauthors.org/dist/File-Remove>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers
|
||||
|
||||
The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions.
|
||||
|
||||
L<http://www.cpantesters.org/distro/F/File-Remove>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Matrix
|
||||
|
||||
The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
|
||||
|
||||
L<http://matrix.cpantesters.org/?dist=File-Remove>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Dependencies
|
||||
|
||||
The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
|
||||
|
||||
L<http://deps.cpantesters.org/?module=File::Remove>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests by email to C<bug-file-remove at rt.cpan.org>, or through
|
||||
the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=File-Remove>. You will be automatically notified of any
|
||||
progress on the request by the system.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
The code is open to the world, and available for you to hack on. Please feel free to browse it and play
|
||||
with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
|
||||
from your repository :)
|
||||
|
||||
L<https://github.com/shlomif/File-Remove>
|
||||
|
||||
git clone git://github.com/shlomif/File-Remove.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Shlomi Fish <shlomif@cpan.org>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests on the bugtracker website
|
||||
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Remove> or by email to
|
||||
L<bug-file-remove@rt.cpan.org|mailto:bug-file-remove@rt.cpan.org>.
|
||||
|
||||
When submitting a bug or request, please include a test-file or a
|
||||
patch to an existing test-file that illustrates the bug or desired
|
||||
feature.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 1998 by Gabor Egressy.
|
||||
|
||||
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
|
||||
660
database/perl/vendor/lib/File/ShareDir.pm
vendored
Normal file
660
database/perl/vendor/lib/File/ShareDir.pm
vendored
Normal file
@@ -0,0 +1,660 @@
|
||||
package File::ShareDir;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::ShareDir - Locate per-dist and per-module shared files
|
||||
|
||||
=begin html
|
||||
|
||||
<a href="https://travis-ci.org/perl5-utils/File-ShareDir"><img src="https://travis-ci.org/perl5-utils/File-ShareDir.svg?branch=master" alt="Travis CI"/></a>
|
||||
<a href='https://coveralls.io/github/perl5-utils/File-ShareDir?branch=master'><img src='https://coveralls.io/repos/github/perl5-utils/File-ShareDir/badge.svg?branch=master' alt='Coverage Status' /></a>
|
||||
<a href="https://saythanks.io/to/rehsack"><img src="https://img.shields.io/badge/Say%20Thanks-!-1EAEDB.svg" alt="Say Thanks" /></a>
|
||||
|
||||
=end html
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::ShareDir ':ALL';
|
||||
|
||||
# Where are distribution-level shared data files kept
|
||||
$dir = dist_dir('File-ShareDir');
|
||||
|
||||
# Where are module-level shared data files kept
|
||||
$dir = module_dir('File::ShareDir');
|
||||
|
||||
# Find a specific file in our dist/module shared dir
|
||||
$file = dist_file( 'File-ShareDir', 'file/name.txt');
|
||||
$file = module_file('File::ShareDir', 'file/name.txt');
|
||||
|
||||
# Like module_file, but search up the inheritance tree
|
||||
$file = class_file( 'Foo::Bar', 'file/name.txt' );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The intent of L<File::ShareDir> is to provide a companion to
|
||||
L<Class::Inspector> and L<File::HomeDir>, modules that take a
|
||||
process that is well-known by advanced Perl developers but gets a
|
||||
little tricky, and make it more available to the larger Perl community.
|
||||
|
||||
Quite often you want or need your Perl module (CPAN or otherwise)
|
||||
to have access to a large amount of read-only data that is stored
|
||||
on the file-system at run-time.
|
||||
|
||||
On a linux-like system, this would be in a place such as /usr/share,
|
||||
however Perl runs on a wide variety of different systems, and so
|
||||
the use of any one location is unreliable.
|
||||
|
||||
Perl provides a little-known method for doing this, but almost
|
||||
nobody is aware that it exists. As a result, module authors often
|
||||
go through some very strange ways to make the data available to
|
||||
their code.
|
||||
|
||||
The most common of these is to dump the data out to an enormous
|
||||
Perl data structure and save it into the module itself. The
|
||||
result are enormous multi-megabyte .pm files that chew up a
|
||||
lot of memory needlessly.
|
||||
|
||||
Another method is to put the data "file" after the __DATA__ compiler
|
||||
tag and limit yourself to access as a filehandle.
|
||||
|
||||
The problem to solve is really quite simple.
|
||||
|
||||
1. Write the data files to the system at install time.
|
||||
|
||||
2. Know where you put them at run-time.
|
||||
|
||||
Perl's install system creates an "auto" directory for both
|
||||
every distribution and for every module file.
|
||||
|
||||
These are used by a couple of different auto-loading systems
|
||||
to store code fragments generated at install time, and various
|
||||
other modules written by the Perl "ancient masters".
|
||||
|
||||
But the same mechanism is available to any dist or module to
|
||||
store any sort of data.
|
||||
|
||||
=head2 Using Data in your Module
|
||||
|
||||
C<File::ShareDir> forms one half of a two part solution.
|
||||
|
||||
Once the files have been installed to the correct directory,
|
||||
you can use C<File::ShareDir> to find your files again after
|
||||
the installation.
|
||||
|
||||
For the installation half of the solution, see L<File::ShareDir::Install>
|
||||
and its C<install_share> directive.
|
||||
|
||||
Using L<File::ShareDir::Install> together with L<File::ShareDir>
|
||||
allows one to rely on the files in appropriate C<dist_dir()>
|
||||
or C<module_dir()> in development phase, too.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
C<File::ShareDir> provides four functions for locating files and
|
||||
directories.
|
||||
|
||||
For greater maintainability, none of these are exported by default
|
||||
and you are expected to name the ones you want at use-time, or provide
|
||||
the C<':ALL'> tag. All of the following are equivalent.
|
||||
|
||||
# Load but don't import, and then call directly
|
||||
use File::ShareDir;
|
||||
$dir = File::ShareDir::dist_dir('My-Dist');
|
||||
|
||||
# Import a single function
|
||||
use File::ShareDir 'dist_dir';
|
||||
dist_dir('My-Dist');
|
||||
|
||||
# Import all the functions
|
||||
use File::ShareDir ':ALL';
|
||||
dist_dir('My-Dist');
|
||||
|
||||
All of the functions will check for you that the dir/file actually
|
||||
exists, and that you have read permissions, or they will throw an
|
||||
exception.
|
||||
|
||||
=cut
|
||||
|
||||
use 5.005;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base ('Exporter');
|
||||
use constant IS_MACOS => !!($^O eq 'MacOS');
|
||||
use constant IS_WIN32 => !!($^O eq 'MSWin32');
|
||||
|
||||
use Carp ();
|
||||
use Exporter ();
|
||||
use File::Spec ();
|
||||
use Class::Inspector ();
|
||||
|
||||
our %DIST_SHARE;
|
||||
our %MODULE_SHARE;
|
||||
|
||||
our @CARP_NOT;
|
||||
our @EXPORT_OK = qw{
|
||||
dist_dir
|
||||
dist_file
|
||||
module_dir
|
||||
module_file
|
||||
class_dir
|
||||
class_file
|
||||
};
|
||||
our %EXPORT_TAGS = (
|
||||
ALL => [@EXPORT_OK],
|
||||
);
|
||||
our $VERSION = '1.118';
|
||||
|
||||
#####################################################################
|
||||
# Interface Functions
|
||||
|
||||
=pod
|
||||
|
||||
=head2 dist_dir
|
||||
|
||||
# Get a distribution's shared files directory
|
||||
my $dir = dist_dir('My-Distribution');
|
||||
|
||||
The C<dist_dir> function takes a single parameter of the name of an
|
||||
installed (CPAN or otherwise) distribution, and locates the shared
|
||||
data directory created at install time for it.
|
||||
|
||||
Returns the directory path as a string, or dies if it cannot be
|
||||
located or is not readable.
|
||||
|
||||
=cut
|
||||
|
||||
sub dist_dir
|
||||
{
|
||||
my $dist = _DIST(shift);
|
||||
my $dir;
|
||||
|
||||
# Try the new version, then fall back to the legacy version
|
||||
$dir = _dist_dir_new($dist) || _dist_dir_old($dist);
|
||||
|
||||
return $dir if defined $dir;
|
||||
|
||||
# Ran out of options
|
||||
Carp::croak("Failed to find share dir for dist '$dist'");
|
||||
}
|
||||
|
||||
sub _dist_dir_new
|
||||
{
|
||||
my $dist = shift;
|
||||
|
||||
return $DIST_SHARE{$dist} if exists $DIST_SHARE{$dist};
|
||||
|
||||
# Create the subpath
|
||||
my $path = File::Spec->catdir('auto', 'share', 'dist', $dist);
|
||||
|
||||
# Find the full dir within @INC
|
||||
return _search_inc_path($path);
|
||||
}
|
||||
|
||||
sub _dist_dir_old
|
||||
{
|
||||
my $dist = shift;
|
||||
|
||||
# Create the subpath
|
||||
my $path = File::Spec->catdir('auto', split(/-/, $dist),);
|
||||
|
||||
# Find the full dir within @INC
|
||||
return _search_inc_path($path);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 module_dir
|
||||
|
||||
# Get a module's shared files directory
|
||||
my $dir = module_dir('My::Module');
|
||||
|
||||
The C<module_dir> function takes a single parameter of the name of an
|
||||
installed (CPAN or otherwise) module, and locates the shared data
|
||||
directory created at install time for it.
|
||||
|
||||
In order to find the directory, the module B<must> be loaded when
|
||||
calling this function.
|
||||
|
||||
Returns the directory path as a string, or dies if it cannot be
|
||||
located or is not readable.
|
||||
|
||||
=cut
|
||||
|
||||
sub module_dir
|
||||
{
|
||||
my $module = _MODULE(shift);
|
||||
|
||||
return $MODULE_SHARE{$module} if exists $MODULE_SHARE{$module};
|
||||
|
||||
# Try the new version first, then fall back to the legacy version
|
||||
return _module_dir_new($module) || _module_dir_old($module);
|
||||
}
|
||||
|
||||
sub _module_dir_new
|
||||
{
|
||||
my $module = shift;
|
||||
|
||||
# Create the subpath
|
||||
my $path = File::Spec->catdir('auto', 'share', 'module', _module_subdir($module),);
|
||||
|
||||
# Find the full dir within @INC
|
||||
return _search_inc_path($path);
|
||||
}
|
||||
|
||||
sub _module_dir_old
|
||||
{
|
||||
my $module = shift;
|
||||
my $short = Class::Inspector->filename($module);
|
||||
my $long = Class::Inspector->loaded_filename($module);
|
||||
$short =~ tr{/}{:} if IS_MACOS;
|
||||
$short =~ tr{\\} {/} if IS_WIN32;
|
||||
$long =~ tr{\\} {/} if IS_WIN32;
|
||||
substr($short, -3, 3, '');
|
||||
$long =~ m/^(.*)\Q$short\E\.pm\z/s or Carp::croak("Failed to find base dir");
|
||||
my $dir = File::Spec->catdir("$1", 'auto', $short);
|
||||
|
||||
-d $dir or Carp::croak("Directory '$dir': No such directory");
|
||||
-r $dir or Carp::croak("Directory '$dir': No read permission");
|
||||
|
||||
return $dir;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 dist_file
|
||||
|
||||
# Find a file in our distribution shared dir
|
||||
my $dir = dist_file('My-Distribution', 'file/name.txt');
|
||||
|
||||
The C<dist_file> function takes two parameters of the distribution name
|
||||
and file name, locates the dist directory, and then finds the file within
|
||||
it, verifying that the file actually exists, and that it is readable.
|
||||
|
||||
The filename should be a relative path in the format of your local
|
||||
filesystem. It will simply added to the directory using L<File::Spec>'s
|
||||
C<catfile> method.
|
||||
|
||||
Returns the file path as a string, or dies if the file or the dist's
|
||||
directory cannot be located, or the file is not readable.
|
||||
|
||||
=cut
|
||||
|
||||
sub dist_file
|
||||
{
|
||||
my $dist = _DIST(shift);
|
||||
my $file = _FILE(shift);
|
||||
|
||||
# Try the new version first, in doubt hand off to the legacy version
|
||||
my $path = _dist_file_new($dist, $file) || _dist_file_old($dist, $file);
|
||||
$path or Carp::croak("Failed to find shared file '$file' for dist '$dist'");
|
||||
|
||||
-f $path or Carp::croak("File '$path': No such file");
|
||||
-r $path or Carp::croak("File '$path': No read permission");
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
sub _dist_file_new
|
||||
{
|
||||
my $dist = shift;
|
||||
my $file = shift;
|
||||
|
||||
# If it exists, what should the path be
|
||||
my $dir = _dist_dir_new($dist);
|
||||
return undef unless defined $dir;
|
||||
my $path = File::Spec->catfile($dir, $file);
|
||||
|
||||
# Does the file exist
|
||||
return undef unless -e $path;
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
sub _dist_file_old
|
||||
{
|
||||
my $dist = shift;
|
||||
my $file = shift;
|
||||
|
||||
# If it exists, what should the path be
|
||||
my $dir = _dist_dir_old($dist);
|
||||
return undef unless defined $dir;
|
||||
my $path = File::Spec->catfile($dir, $file);
|
||||
|
||||
# Does the file exist
|
||||
return undef unless -e $path;
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 module_file
|
||||
|
||||
# Find a file in our module shared dir
|
||||
my $dir = module_file('My::Module', 'file/name.txt');
|
||||
|
||||
The C<module_file> function takes two parameters of the module name
|
||||
and file name. It locates the module directory, and then finds the file
|
||||
within it, verifying that the file actually exists, and that it is readable.
|
||||
|
||||
In order to find the directory, the module B<must> be loaded when
|
||||
calling this function.
|
||||
|
||||
The filename should be a relative path in the format of your local
|
||||
filesystem. It will simply added to the directory using L<File::Spec>'s
|
||||
C<catfile> method.
|
||||
|
||||
Returns the file path as a string, or dies if the file or the dist's
|
||||
directory cannot be located, or the file is not readable.
|
||||
|
||||
=cut
|
||||
|
||||
sub module_file
|
||||
{
|
||||
my $module = _MODULE(shift);
|
||||
my $file = _FILE(shift);
|
||||
my $dir = module_dir($module);
|
||||
my $path = File::Spec->catfile($dir, $file);
|
||||
|
||||
-e $path or Carp::croak("File '$path' does not exist in module dir");
|
||||
-r $path or Carp::croak("File '$path': No read permission");
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 class_file
|
||||
|
||||
# Find a file in our module shared dir, or in our parent class
|
||||
my $dir = class_file('My::Module', 'file/name.txt');
|
||||
|
||||
The C<module_file> function takes two parameters of the module name
|
||||
and file name. It locates the module directory, and then finds the file
|
||||
within it, verifying that the file actually exists, and that it is readable.
|
||||
|
||||
In order to find the directory, the module B<must> be loaded when
|
||||
calling this function.
|
||||
|
||||
The filename should be a relative path in the format of your local
|
||||
filesystem. It will simply added to the directory using L<File::Spec>'s
|
||||
C<catfile> method.
|
||||
|
||||
If the file is NOT found for that module, C<class_file> will scan up
|
||||
the module's @ISA tree, looking for the file in all of the parent
|
||||
classes.
|
||||
|
||||
This allows you to, in effect, "subclass" shared files.
|
||||
|
||||
Returns the file path as a string, or dies if the file or the dist's
|
||||
directory cannot be located, or the file is not readable.
|
||||
|
||||
=cut
|
||||
|
||||
sub class_file
|
||||
{
|
||||
my $module = _MODULE(shift);
|
||||
my $file = _FILE(shift);
|
||||
|
||||
# Get the super path ( not including UNIVERSAL )
|
||||
# Rather than using Class::ISA, we'll use an inlined version
|
||||
# that implements the same basic algorithm.
|
||||
my @path = ();
|
||||
my @queue = ($module);
|
||||
my %seen = ($module => 1);
|
||||
while (my $cl = shift @queue)
|
||||
{
|
||||
push @path, $cl;
|
||||
no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
|
||||
unshift @queue, grep { !$seen{$_}++ }
|
||||
map { my $s = $_; $s =~ s/^::/main::/; $s =~ s/\'/::/g; $s } (@{"${cl}::ISA"});
|
||||
}
|
||||
|
||||
# Search up the path
|
||||
foreach my $class (@path)
|
||||
{
|
||||
my $dir = eval { module_dir($class); };
|
||||
next if $@;
|
||||
my $path = File::Spec->catfile($dir, $file);
|
||||
-e $path or next;
|
||||
-r $path or Carp::croak("File '$file' cannot be read, no read permissions");
|
||||
return $path;
|
||||
}
|
||||
Carp::croak("File '$file' does not exist in class or parent shared files");
|
||||
}
|
||||
|
||||
## no critic (BuiltinFunctions::ProhibitStringyEval)
|
||||
if (eval "use List::MoreUtils 0.428; 1;")
|
||||
{
|
||||
List::MoreUtils->import("firstres");
|
||||
}
|
||||
else
|
||||
{
|
||||
## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
eval <<'END_OF_BORROWED_CODE';
|
||||
sub firstres (&@)
|
||||
{
|
||||
my $test = shift;
|
||||
foreach (@_)
|
||||
{
|
||||
my $testval = $test->();
|
||||
$testval and return $testval;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
END_OF_BORROWED_CODE
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Support Functions
|
||||
|
||||
sub _search_inc_path
|
||||
{
|
||||
my $path = shift;
|
||||
|
||||
# Find the full dir within @INC
|
||||
my $dir = firstres(
|
||||
sub {
|
||||
my $d;
|
||||
$d = File::Spec->catdir($_, $path) if defined _STRING($_);
|
||||
defined $d and -d $d ? $d : 0;
|
||||
},
|
||||
@INC
|
||||
) or return;
|
||||
|
||||
Carp::croak("Found directory '$dir', but no read permissions") unless -r $dir;
|
||||
|
||||
return $dir;
|
||||
}
|
||||
|
||||
sub _module_subdir
|
||||
{
|
||||
my $module = shift;
|
||||
$module =~ s/::/-/g;
|
||||
return $module;
|
||||
}
|
||||
|
||||
## no critic (BuiltinFunctions::ProhibitStringyEval)
|
||||
if (eval "use Params::Util 1.07; 1;")
|
||||
{
|
||||
Params::Util->import("_CLASS", "_STRING");
|
||||
}
|
||||
else
|
||||
{
|
||||
## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
eval <<'END_OF_BORROWED_CODE';
|
||||
# Inlined from Params::Util pure perl version
|
||||
sub _CLASS ($)
|
||||
{
|
||||
return (defined $_[0] and !ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
sub _STRING ($)
|
||||
{
|
||||
(defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
|
||||
}
|
||||
END_OF_BORROWED_CODE
|
||||
}
|
||||
|
||||
# Maintainer note: The following private functions are used by
|
||||
# File::ShareDir::PAR. (It has to or else it would have to copy&fork)
|
||||
# So if you significantly change or even remove them, please
|
||||
# notify the File::ShareDir::PAR maintainer(s). Thank you!
|
||||
|
||||
# Matches a valid distribution name
|
||||
### This is a total guess at this point
|
||||
sub _DIST ## no critic (Subroutines::RequireArgUnpacking)
|
||||
{
|
||||
defined _STRING($_[0]) and $_[0] =~ /^[a-z0-9+_-]+$/is and return $_[0];
|
||||
Carp::croak("Not a valid distribution name");
|
||||
}
|
||||
|
||||
# A valid and loaded module name
|
||||
sub _MODULE
|
||||
{
|
||||
my $module = _CLASS(shift) or Carp::croak("Not a valid module name");
|
||||
Class::Inspector->loaded($module) and return $module;
|
||||
Carp::croak("Module '$module' is not loaded");
|
||||
}
|
||||
|
||||
# A valid file name
|
||||
sub _FILE
|
||||
{
|
||||
my $file = shift;
|
||||
_STRING($file) or Carp::croak("Did not pass a file name");
|
||||
File::Spec->file_name_is_absolute($file) and Carp::croak("Cannot use absolute file name '$file'");
|
||||
return $file;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 EXTENDING
|
||||
|
||||
=head2 Overriding Directory Resolution
|
||||
|
||||
C<File::ShareDir> has two convenience hashes for people who have advanced usage
|
||||
requirements of C<File::ShareDir> such as using uninstalled C<share>
|
||||
directories during development.
|
||||
|
||||
#
|
||||
# Dist-Name => /absolute/path/for/DistName/share/dir
|
||||
#
|
||||
%File::ShareDir::DIST_SHARE
|
||||
|
||||
#
|
||||
# Module::Name => /absolute/path/for/Module/Name/share/dir
|
||||
#
|
||||
%File::ShareDir::MODULE_SHARE
|
||||
|
||||
Setting these values any time before the corresponding calls
|
||||
|
||||
dist_dir('Dist-Name')
|
||||
dist_file('Dist-Name','some/file');
|
||||
|
||||
module_dir('Module::Name');
|
||||
module_file('Module::Name','some/file');
|
||||
|
||||
Will override the base directory for resolving those calls.
|
||||
|
||||
An example of where this would be useful is in a test for a module that
|
||||
depends on files installed into a share directory, to enable the tests
|
||||
to use the development copy without needing to install them first.
|
||||
|
||||
use File::ShareDir;
|
||||
use Cwd qw( getcwd );
|
||||
use File::Spec::Functions qw( rel2abs catdir );
|
||||
|
||||
$File::ShareDir::MODULE_SHARE{'Foo::Module'} = rel2abs(catfile(getcwd,'share'));
|
||||
|
||||
use Foo::Module;
|
||||
|
||||
# internal calls in Foo::Module to module_file('Foo::Module','bar') now resolves to
|
||||
# the source trees share/ directory instead of something in @INC
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs should always be submitted via the CPAN request tracker, see below.
|
||||
|
||||
You can find documentation for this module with the perldoc command.
|
||||
|
||||
perldoc File::ShareDir
|
||||
|
||||
You can also look for information at:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * RT: CPAN's request tracker
|
||||
|
||||
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-ShareDir>
|
||||
|
||||
=item * AnnoCPAN: Annotated CPAN documentation
|
||||
|
||||
L<http://annocpan.org/dist/File-ShareDir>
|
||||
|
||||
=item * CPAN Ratings
|
||||
|
||||
L<http://cpanratings.perl.org/s/File-ShareDir>
|
||||
|
||||
=item * CPAN Search
|
||||
|
||||
L<http://search.cpan.org/dist/File-ShareDir/>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Where can I go for other help?
|
||||
|
||||
If you have a bug report, a patch or a suggestion, please open a new
|
||||
report ticket at CPAN (but please check previous reports first in case
|
||||
your issue has already been addressed).
|
||||
|
||||
Report tickets should contain a detailed description of the bug or
|
||||
enhancement request and at least an easily verifiable way of
|
||||
reproducing the issue or fix. Patches are always welcome, too.
|
||||
|
||||
=head2 Where can I go for help with a concrete version?
|
||||
|
||||
Bugs and feature requests are accepted against the latest version
|
||||
only. To get patches for earlier versions, you need to get an
|
||||
agreement with a developer of your choice - who may or not report the
|
||||
issue and a suggested fix upstream (depends on the license you have
|
||||
chosen).
|
||||
|
||||
=head2 Business support and maintenance
|
||||
|
||||
For business support you can contact the maintainer via his CPAN
|
||||
email address. Please keep in mind that business support is neither
|
||||
available for free nor are you eligible to receive any support
|
||||
based on the license distributed with this package.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head2 MAINTAINER
|
||||
|
||||
Jens Rehsack E<lt>rehsack@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::ShareDir::Install>,
|
||||
L<File::ConfigDir>, L<File::HomeDir>,
|
||||
L<Module::Install>, L<Module::Install::Share>,
|
||||
L<File::ShareDir::PAR>, L<Dist::Zilla::Plugin::ShareDir>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2005 - 2011 Adam Kennedy,
|
||||
Copyright 2014 - 2018 Jens Rehsack.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
433
database/perl/vendor/lib/File/ShareDir/Install.pm
vendored
Normal file
433
database/perl/vendor/lib/File/ShareDir/Install.pm
vendored
Normal file
@@ -0,0 +1,433 @@
|
||||
package File::ShareDir::Install; # git description: v0.12-6-g29a6ff7
|
||||
# ABSTRACT: Install shared files
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp ();
|
||||
|
||||
use File::Spec;
|
||||
use IO::Dir;
|
||||
|
||||
our $VERSION = '0.13';
|
||||
|
||||
our @DIRS;
|
||||
our %ALREADY;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw( Exporter );
|
||||
our @EXPORT = qw( install_share delete_share );
|
||||
our @EXPORT_OK = qw( postamble install_share delete_share );
|
||||
our $INCLUDE_DOTFILES = 0;
|
||||
our $INCLUDE_DOTDIRS = 0;
|
||||
|
||||
#####################################################################
|
||||
sub install_share
|
||||
{
|
||||
my $dir = @_ ? pop : 'share';
|
||||
my $type = @_ ? shift : 'dist';
|
||||
unless ( defined $type and
|
||||
( $type =~ /^(module|dist)$/ ) ) {
|
||||
Carp::confess "Illegal or invalid share dir type '$type'";
|
||||
}
|
||||
|
||||
if( $type eq 'dist' and @_ ) {
|
||||
Carp::confess "Too many parameters to install_share";
|
||||
}
|
||||
|
||||
my $def = _mk_def( $type );
|
||||
_add_module( $def, $_[0] );
|
||||
|
||||
_add_dir( $def, $dir );
|
||||
}
|
||||
|
||||
|
||||
#####################################################################
|
||||
sub delete_share
|
||||
{
|
||||
my $dir = @_ ? pop : '';
|
||||
my $type = @_ ? shift : 'dist';
|
||||
unless ( defined $type and
|
||||
( $type =~ /^(module|dist)$/ ) ) {
|
||||
Carp::confess "Illegal or invalid share dir type '$type'";
|
||||
}
|
||||
|
||||
if( $type eq 'dist' and @_ ) {
|
||||
Carp::confess "Too many parameters to delete_share";
|
||||
}
|
||||
|
||||
my $def = _mk_def( "delete-$type" );
|
||||
_add_module( $def, $_[0] );
|
||||
_add_dir( $def, $dir );
|
||||
}
|
||||
|
||||
|
||||
|
||||
#
|
||||
# Build a task definition
|
||||
sub _mk_def
|
||||
{
|
||||
my( $type ) = @_;
|
||||
return { type=>$type,
|
||||
dotfiles => $INCLUDE_DOTFILES,
|
||||
dotdirs => $INCLUDE_DOTDIRS
|
||||
};
|
||||
}
|
||||
|
||||
#
|
||||
# Add the module to a task definition
|
||||
sub _add_module
|
||||
{
|
||||
my( $def, $class ) = @_;
|
||||
if( $def->{type} =~ /module$/ ) {
|
||||
my $module = _CLASS( $class );
|
||||
unless ( defined $module ) {
|
||||
Carp::confess "Missing or invalid module name '$_[0]'";
|
||||
}
|
||||
$def->{module} = $module;
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Add directories to a task definition
|
||||
# Save the definition
|
||||
sub _add_dir
|
||||
{
|
||||
my( $def, $dir ) = @_;
|
||||
|
||||
$dir = [ $dir ] unless ref $dir;
|
||||
|
||||
my $del = 0;
|
||||
$del = 1 if $def->{type} =~ /^delete-/;
|
||||
|
||||
foreach my $d ( @$dir ) {
|
||||
unless ( $del or (defined $d and -d $d) ) {
|
||||
Carp::confess "Illegal or missing directory '$d'";
|
||||
}
|
||||
if( not $del and $ALREADY{ $d }++ ) {
|
||||
Carp::confess "Directory '$d' is already being installed";
|
||||
}
|
||||
push @DIRS, { %$def };
|
||||
$DIRS[-1]{dir} = $d;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Build the postamble section
|
||||
sub postamble
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my @ret; # = $self->SUPER::postamble( @_ );
|
||||
foreach my $def ( @DIRS ) {
|
||||
push @ret, __postamble_share_dir( $self, $def );
|
||||
}
|
||||
return join "\n", @ret;
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
sub __postamble_share_dir
|
||||
{
|
||||
my( $self, $def ) = @_;
|
||||
|
||||
my $dir = $def->{dir};
|
||||
|
||||
my( $idir );
|
||||
|
||||
if( $def->{type} eq 'delete-dist' ) {
|
||||
$idir = File::Spec->catdir( _dist_dir(), $dir );
|
||||
}
|
||||
elsif( $def->{type} eq 'delete-module' ) {
|
||||
$idir = File::Spec->catdir( _module_dir( $def ), $dir );
|
||||
}
|
||||
elsif ( $def->{type} eq 'dist' ) {
|
||||
$idir = _dist_dir();
|
||||
}
|
||||
else { # delete-share and share
|
||||
$idir = _module_dir( $def );
|
||||
}
|
||||
|
||||
my @cmds;
|
||||
if( $def->{type} =~ /^delete-/ ) {
|
||||
@cmds = "\$(RM_RF) $idir";
|
||||
}
|
||||
else {
|
||||
my $autodir = '$(INST_LIB)';
|
||||
my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']);
|
||||
pm_to_blib({\@ARGV}, '$autodir')
|
||||
CODE
|
||||
|
||||
my $files = {};
|
||||
_scan_share_dir( $files, $idir, $dir, $def );
|
||||
@cmds = $self->split_command( $pm_to_blib,
|
||||
map { ($self->quote_literal($_) => $self->quote_literal($files->{$_})) } sort keys %$files );
|
||||
}
|
||||
|
||||
my $r = join '', map { "\t\$(NOECHO) $_\n" } @cmds;
|
||||
|
||||
# use Data::Dumper;
|
||||
# die Dumper $files;
|
||||
# Set up the install
|
||||
return "config::\n$r";
|
||||
}
|
||||
|
||||
# Get the per-dist install directory.
|
||||
# We depend on the Makefile for most of the info
|
||||
sub _dist_dir
|
||||
{
|
||||
return File::Spec->catdir( '$(INST_LIB)',
|
||||
qw( auto share dist ),
|
||||
'$(DISTNAME)'
|
||||
);
|
||||
}
|
||||
|
||||
# Get the per-module install directory
|
||||
# We depend on the Makefile for most of the info
|
||||
sub _module_dir
|
||||
{
|
||||
my( $def ) = @_;
|
||||
my $module = $def->{module};
|
||||
$module =~ s/::/-/g;
|
||||
return File::Spec->catdir( '$(INST_LIB)',
|
||||
qw( auto share module ),
|
||||
$module
|
||||
);
|
||||
}
|
||||
|
||||
sub _scan_share_dir
|
||||
{
|
||||
my( $files, $idir, $dir, $def ) = @_;
|
||||
my $dh = IO::Dir->new( $dir ) or die "Unable to read $dir: $!";
|
||||
my $entry;
|
||||
while( defined( $entry = $dh->read ) ) {
|
||||
next if $entry =~ /(~|,v|#)$/;
|
||||
my $full = File::Spec->catfile( $dir, $entry );
|
||||
if( -f $full ) {
|
||||
next if not $def->{dotfiles} and $entry =~ /^\./;
|
||||
$files->{ $full } = File::Spec->catfile( $idir, $entry );
|
||||
}
|
||||
elsif( -d $full ) {
|
||||
if( $def->{dotdirs} ) {
|
||||
next if $entry eq '.' or $entry eq '..' or
|
||||
$entry =~ /^\.(svn|git|cvs)$/;
|
||||
}
|
||||
else {
|
||||
next if $entry =~ /^\./;
|
||||
}
|
||||
_scan_share_dir( $files, File::Spec->catdir( $idir, $entry ), $full, $def );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Cloned from Params::Util::_CLASS
|
||||
sub _CLASS ($) {
|
||||
(
|
||||
defined $_[0]
|
||||
and
|
||||
! ref $_[0]
|
||||
and
|
||||
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
|
||||
) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::ShareDir::Install - Install shared files
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.13
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ExtUtils::MakeMaker;
|
||||
use File::ShareDir::Install;
|
||||
|
||||
install_share 'share';
|
||||
install_share dist => 'dist-share';
|
||||
install_share module => 'My::Module' => 'other-share';
|
||||
|
||||
WriteMakefile( ... ); # As you normally would
|
||||
|
||||
package MY;
|
||||
use File::ShareDir::Install qw(postamble);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
File::ShareDir::Install allows you to install read-only data files from a
|
||||
distribution. It is a companion module to L<File::ShareDir>, which
|
||||
allows you to locate these files after installation.
|
||||
|
||||
It is a port of L<Module::Install::Share> to L<ExtUtils::MakeMaker> with the
|
||||
improvement of only installing the files you want; C<.svn>, C<.git> and other
|
||||
source-control junk will be ignored.
|
||||
|
||||
Please note that this module installs read-only data files; empty
|
||||
directories will be ignored.
|
||||
|
||||
=head1 EXPORT
|
||||
|
||||
=head2 install_share
|
||||
|
||||
install_share $dir;
|
||||
install_share dist => $dir;
|
||||
install_share module => $module, $dir;
|
||||
|
||||
Causes all the files in C<$dir> and its sub-directories to be installed
|
||||
into a per-dist or per-module share directory. Must be called before
|
||||
L<WriteMakefile>.
|
||||
|
||||
The first 2 forms are equivalent; the files are installed in a per-distribution
|
||||
directory. For example C</usr/lib/perl5/site_perl/auto/share/dist/My-Dist>. The
|
||||
name of that directory can be recovered with L<File::ShareDir/dist_dir>.
|
||||
|
||||
The last form installs files in a per-module directory. For example
|
||||
C</usr/lib/perl5/site_perl/auto/share/module/My-Dist-Package>. The name of that
|
||||
directory can be recovered with L<File::ShareDir/module_dir>.
|
||||
|
||||
The parameter C<$dir> may be an array of directories.
|
||||
|
||||
The files will be installed when you run C<make install>. However, the list
|
||||
of files to install is generated when Makefile.PL is run.
|
||||
|
||||
Note that if you make multiple calls to C<install_share> on different
|
||||
directories that contain the same filenames, the last of these calls takes
|
||||
precedence. In other words, if you do:
|
||||
|
||||
install_share 'share1';
|
||||
install_share 'share2';
|
||||
|
||||
And both C<share1> and C<share2> contain a file called C<info.txt>, the file
|
||||
C<share2/info.txt> will be installed into your C<dist_dir()>.
|
||||
|
||||
=head2 delete_share
|
||||
|
||||
delete_share $list;
|
||||
delete_share dist => $list;
|
||||
delete_share module => $module, $list;
|
||||
|
||||
Remove previously installed files or directories.
|
||||
|
||||
Unlike L</install_share>, the last parameter is a list of files or
|
||||
directories that were previously installed. These files and directories will
|
||||
be deleted when you run C<make install>.
|
||||
|
||||
The parameter C<$list> may be an array of files or directories.
|
||||
|
||||
Deletion happens in-order along with installation. This means that you may
|
||||
delete all previously installed files by putting the following at the top of
|
||||
your Makefile.PL.
|
||||
|
||||
delete_share '.';
|
||||
|
||||
You can also selectively remove some files from installation.
|
||||
|
||||
install_share 'some-dir';
|
||||
if( ... ) {
|
||||
delete_share 'not-this-file.rc';
|
||||
}
|
||||
|
||||
=head2 postamble
|
||||
|
||||
This function must be exported into the MY package. You will normally do this
|
||||
with the following.
|
||||
|
||||
package MY;
|
||||
use File::ShareDir::Install qw( postamble );
|
||||
|
||||
If you need to overload postamble, use the following.
|
||||
|
||||
package MY;
|
||||
use File::ShareDir::Install;
|
||||
|
||||
sub postamble {
|
||||
my $self = shift;
|
||||
my @ret = File::ShareDir::Install::postamble( $self );
|
||||
# ... add more things to @ret;
|
||||
return join "\n", @ret;
|
||||
}
|
||||
|
||||
=head1 CONFIGURATION
|
||||
|
||||
Two variables control the handling of dot-files and dot-directories.
|
||||
|
||||
A dot-file has a filename that starts with a period (.). For example
|
||||
C<.htaccess>. A dot-directory is a directory that starts with a
|
||||
period (.). For example C<.config/>. Not all filesystems support the use
|
||||
of dot-files.
|
||||
|
||||
=head2 $INCLUDE_DOTFILES
|
||||
|
||||
If set to a true value, dot-files will be copied. Default is false.
|
||||
|
||||
=head2 $INCLUDE_DOTDIRS
|
||||
|
||||
If set to a true value, the files inside dot-directories will be copied.
|
||||
Known version control directories are still ignored. Default is false.
|
||||
|
||||
=head2 Note
|
||||
|
||||
These variables only influence subsequent calls to C<install_share()>. This allows
|
||||
you to control the behaviour for each directory.
|
||||
|
||||
For example:
|
||||
|
||||
$INCLUDE_DOTDIRS = 1;
|
||||
install_share 'share1';
|
||||
$INCLUDE_DOTFILES = 1;
|
||||
$INCLUDE_DOTDIRS = 0;
|
||||
install_share 'share2';
|
||||
|
||||
The directory C<share1> will have files in its dot-directories installed,
|
||||
but not dot-files. The directory C<share2> will have files in its dot-files
|
||||
installed, but dot-directories will be ignored.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::ShareDir>, L<Module::Install>.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=File-ShareDir-Install>
|
||||
(or L<bug-File-ShareDir-Install@rt.cpan.org|mailto:bug-File-ShareDir-Install@rt.cpan.org>).
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Philip Gwyn <gwyn@cpan.org>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
=for stopwords Karen Etheridge Shoichi Kaji
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shoichi Kaji <skaji@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2009 by Philip Gwyn.
|
||||
|
||||
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
|
||||
1128
database/perl/vendor/lib/File/Slurp.pm
vendored
Normal file
1128
database/perl/vendor/lib/File/Slurp.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
193
database/perl/vendor/lib/File/Slurp/Tiny.pm
vendored
Normal file
193
database/perl/vendor/lib/File/Slurp/Tiny.pm
vendored
Normal file
@@ -0,0 +1,193 @@
|
||||
package File::Slurp::Tiny;
|
||||
$File::Slurp::Tiny::VERSION = '0.004';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp 'croak';
|
||||
use Exporter 5.57 'import';
|
||||
use File::Spec::Functions 'catfile';
|
||||
use FileHandle;
|
||||
our @EXPORT_OK = qw/read_file read_lines write_file read_dir/;
|
||||
|
||||
my $default_layer = $^O eq 'MSWin32' ? ':crlf' : ':unix';
|
||||
|
||||
sub read_file {
|
||||
my ($filename, %options) = @_;
|
||||
my $layer = $options{binmode} || $default_layer;
|
||||
my $buf_ref = defined $options{buf_ref} ? $options{buf_ref} : \my $buf;
|
||||
|
||||
open my $fh, "<$layer", $filename or croak "Couldn't open $filename: $!";
|
||||
if (my $size = -s $fh) {
|
||||
my ($pos, $read) = 0;
|
||||
do {
|
||||
defined($read = read $fh, ${$buf_ref}, $size - $pos, $pos) or croak "Couldn't read $filename: $!";
|
||||
$pos += $read;
|
||||
} while ($read && $pos < $size);
|
||||
}
|
||||
else {
|
||||
${$buf_ref} = do { local $/; <$fh> };
|
||||
}
|
||||
close $fh;
|
||||
return if not defined wantarray or $options{buf_ref};
|
||||
return $options{scalar_ref} ? $buf_ref : $buf;
|
||||
}
|
||||
|
||||
sub read_lines {
|
||||
my ($filename, %options) = @_;
|
||||
my $layer = delete $options{binmode} || ':';
|
||||
|
||||
open my $fh, "<$layer", $filename or croak "Couldn't open $filename: $!";
|
||||
return <$fh> if not %options;
|
||||
my @buf = <$fh>;
|
||||
close $fh;
|
||||
chomp @buf if $options{chomp};
|
||||
return $options{array_ref} ? \@buf : @buf;
|
||||
}
|
||||
|
||||
sub write_file {
|
||||
my ($filename, undef, %options) = @_;
|
||||
my $layer = $options{binmode} || $default_layer;
|
||||
my $mode = $options{append} ? '>>' : '>';
|
||||
my $buf_ref = defined $options{buf_ref} ? $options{buf_ref} : \$_[1];
|
||||
|
||||
open my $fh, $mode.$layer, $filename or croak "Couldn't open $filename: $!";
|
||||
$fh->autoflush(1);
|
||||
print $fh ${$buf_ref} or croak "Couldn't write to $filename: $!";
|
||||
close $fh or croak "Couldn't close $filename: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
sub read_dir {
|
||||
my ($dirname, %options) = @_;
|
||||
opendir my ($dir), $dirname or croak "Could not open $dirname: $!";
|
||||
my @ret = grep { not m/ \A \.\.? \z /x } readdir $dir;
|
||||
@ret = map { catfile($dirname, $_) } @ret if $options{prefix};
|
||||
closedir $dir;
|
||||
return @ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# ABSTRACT: A simple, sane and efficient file slurper [DISCOURAGED]
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Slurp::Tiny - A simple, sane and efficient file slurper [DISCOURAGED]
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.004
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Slurp::Tiny 'read_file';
|
||||
my $content = read_file($filename);
|
||||
|
||||
=head1 DISCOURAGED
|
||||
|
||||
B<This module is discouraged in favor of L<File::Slurper|File::Slurper>>. While a useful experiment, it turned out to be both too similar to File::Slurp (still containing most problematic features of File::Slurp's interface) and yet not similar enough to be a true drop-in replacement.
|
||||
|
||||
Bugs will still be fixed, but new features will probably not be added.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides functions for fast and correct slurping and spewing. All functions are optionally exported.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 read_file($filename, %options)
|
||||
|
||||
Reads file C<$filename> into a scalar. By default it returns this scalar. Can optionally take these named arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * binmode
|
||||
|
||||
Set the layers to read the file with. The default will be something sensible on your platform.
|
||||
|
||||
=item * buf_ref
|
||||
|
||||
Pass a reference to a scalar to read the file into, instead of returning it by value. This has performance benefits.
|
||||
|
||||
=item * scalar_ref
|
||||
|
||||
If set to true, C<read_file> will return a reference to a scalar containing the file content.
|
||||
|
||||
=back
|
||||
|
||||
=head2 read_lines($filename, %options)
|
||||
|
||||
Reads file C<$filename> into a list/array. By default it returns this list. Can optionally take these named arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * binmode
|
||||
|
||||
Set the layers to read the file with. The default will be something sensible on your platform.
|
||||
|
||||
=item * array_ref
|
||||
|
||||
Pass a reference to an array to read the lines into, instead of returning them by value. This has performance benefits.
|
||||
|
||||
=item * chomp
|
||||
|
||||
C<chomp> the lines.
|
||||
|
||||
=back
|
||||
|
||||
=head2 write_file($filename, $content, %options)
|
||||
|
||||
Open C<$filename>, and write C<$content> to it. Can optionally take this named argument:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * binmode
|
||||
|
||||
Set the layers to write the file with. The default will be something sensible on your platform.
|
||||
|
||||
=back
|
||||
|
||||
=head2 read_dir($dirname, %options)
|
||||
|
||||
Open C<dirname> and return all entries except C<.> and C<..>. Can optionally take this named argument:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * prefix
|
||||
|
||||
This will prepend C<$dir> to the entries
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item * L<Path::Tiny>
|
||||
|
||||
A minimalistic abstraction not only around
|
||||
|
||||
=item * L<File::Slurp>
|
||||
|
||||
Another file slurping tool.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Leon Timmermans <leont@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2013 by Leon Timmermans.
|
||||
|
||||
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
|
||||
206
database/perl/vendor/lib/File/Slurper.pm
vendored
Normal file
206
database/perl/vendor/lib/File/Slurper.pm
vendored
Normal file
@@ -0,0 +1,206 @@
|
||||
package File::Slurper;
|
||||
$File::Slurper::VERSION = '0.012';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp 'croak';
|
||||
use Exporter 5.57 'import';
|
||||
|
||||
use Encode 2.11 qw/FB_CROAK STOP_AT_PARTIAL/;
|
||||
use PerlIO::encoding;
|
||||
|
||||
our @EXPORT_OK = qw/read_binary read_text read_lines write_binary write_text read_dir/;
|
||||
|
||||
sub read_binary {
|
||||
my $filename = shift;
|
||||
|
||||
# This logic is a bit ugly, but gives a significant speed boost
|
||||
# because slurpy readline is not optimized for non-buffered usage
|
||||
open my $fh, '<:unix', $filename or croak "Couldn't open $filename: $!";
|
||||
if (my $size = -s $fh) {
|
||||
my $buf;
|
||||
my ($pos, $read) = 0;
|
||||
do {
|
||||
defined($read = read $fh, ${$buf}, $size - $pos, $pos) or croak "Couldn't read $filename: $!";
|
||||
$pos += $read;
|
||||
} while ($read && $pos < $size);
|
||||
return ${$buf};
|
||||
}
|
||||
else {
|
||||
return do { local $/; <$fh> };
|
||||
}
|
||||
}
|
||||
|
||||
use constant {
|
||||
CRLF_DEFAULT => $^O eq 'MSWin32',
|
||||
HAS_UTF8_STRICT => scalar do { local $@; eval { require PerlIO::utf8_strict } },
|
||||
};
|
||||
|
||||
sub _text_layers {
|
||||
my ($encoding, $crlf) = @_;
|
||||
$crlf = CRLF_DEFAULT if $crlf && $crlf eq 'auto';
|
||||
|
||||
if (HAS_UTF8_STRICT && $encoding =~ /^utf-?8\b/i) {
|
||||
return $crlf ? ':unix:utf8_strict:crlf' : ':unix:utf8_strict';
|
||||
}
|
||||
else {
|
||||
# non-ascii compatible encodings such as UTF-16 need encoding before crlf
|
||||
return $crlf ? ":raw:encoding($encoding):crlf" : ":raw:encoding($encoding)";
|
||||
}
|
||||
}
|
||||
|
||||
sub read_text {
|
||||
my ($filename, $encoding, $crlf) = @_;
|
||||
$encoding ||= 'utf-8';
|
||||
my $layer = _text_layers($encoding, $crlf);
|
||||
|
||||
local $PerlIO::encoding::fallback = STOP_AT_PARTIAL | FB_CROAK;
|
||||
open my $fh, "<$layer", $filename or croak "Couldn't open $filename: $!";
|
||||
return do { local $/; <$fh> };
|
||||
}
|
||||
|
||||
sub write_text {
|
||||
my ($filename, undef, $encoding, $crlf) = @_;
|
||||
$encoding ||= 'utf-8';
|
||||
my $layer = _text_layers($encoding, $crlf);
|
||||
|
||||
local $PerlIO::encoding::fallback = STOP_AT_PARTIAL | FB_CROAK;
|
||||
open my $fh, ">$layer", $filename or croak "Couldn't open $filename: $!";
|
||||
print $fh $_[1] or croak "Couldn't write to $filename: $!";
|
||||
close $fh or croak "Couldn't write to $filename: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
sub write_binary {
|
||||
my $filename = $_[0];
|
||||
open my $fh, ">:raw", $filename or croak "Couldn't open $filename: $!";
|
||||
print $fh $_[1] or croak "Couldn't write to $filename: $!";
|
||||
close $fh or croak "Couldn't write to $filename: $!";
|
||||
return;
|
||||
}
|
||||
|
||||
sub read_lines {
|
||||
my ($filename, $encoding, $crlf, $skip_chomp) = @_;
|
||||
$encoding ||= 'utf-8';
|
||||
my $layer = _text_layers($encoding, $crlf);
|
||||
|
||||
local $PerlIO::encoding::fallback = STOP_AT_PARTIAL | FB_CROAK;
|
||||
open my $fh, "<$layer", $filename or croak "Couldn't open $filename: $!";
|
||||
return <$fh> if $skip_chomp;
|
||||
my @buf = <$fh>;
|
||||
close $fh;
|
||||
chomp @buf;
|
||||
return @buf;
|
||||
}
|
||||
|
||||
sub read_dir {
|
||||
my ($dirname) = @_;
|
||||
opendir my ($dir), $dirname or croak "Could not open $dirname: $!";
|
||||
return grep { not m/ \A \.\.? \z /x } readdir $dir;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# ABSTRACT: A simple, sane and efficient module to slurp a file
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Slurper - A simple, sane and efficient module to slurp a file
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.012
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Slurper 'read_text';
|
||||
my $content = read_text($filename);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides functions for fast and correct slurping and spewing. All functions are optionally exported. All functions throw exceptions on errors, write functions don't return any meaningful value.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 read_text($filename, $encoding, $crlf)
|
||||
|
||||
Reads file C<$filename> into a scalar and decodes it from C<$encoding> (which defaults to UTF-8). If C<$crlf> is true, crlf translation is performed. The default for this argument is off. The special value C<'auto'> will set it to a platform specific default value.
|
||||
|
||||
=head2 read_binary($filename)
|
||||
|
||||
Reads file C<$filename> into a scalar without any decoding or transformation.
|
||||
|
||||
=head2 read_lines($filename, $encoding, $crlf, $skip_chomp)
|
||||
|
||||
Reads file C<$filename> into a list/array line-by-line, after decoding from C<$encoding>, optional crlf translation and chomping.
|
||||
|
||||
=head2 write_text($filename, $content, $encoding, $crlf)
|
||||
|
||||
Writes C<$content> to file C<$filename>, encoding it to C<$encoding> (which defaults to UTF-8). It can also take a C<crlf> argument that works exactly as in read_text.
|
||||
|
||||
=head2 write_binary($filename, $content)
|
||||
|
||||
Writes C<$content> to file C<$filename> as binary data.
|
||||
|
||||
=head2 read_dir($dirname)
|
||||
|
||||
Open C<dirname> and return all entries except C<.> and C<..>.
|
||||
|
||||
=head1 RATIONALE
|
||||
|
||||
This module tries to make it as easy as possible to read and write files correctly and fast. The most correct way of doing this is not always obvious (e.g. L<#83126|https://rt.cpan.org/Public/Bug/Display.html?id=83126>), and just as often the most obvious correct way is not the fastest correct way. This module hides away all such complications behind an easy intuitive interface.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
This module has an optional dependency on L<PerlIO::utf8_strict|PerlIO::utf8_strict>. Installing this will make UTF-8 encoded IO significantly faster, but should not otherwise affect the operation of this module. This may change into a dependency on the related Unicode::UTF8 in the future.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item * L<Path::Tiny|Path::Tiny>
|
||||
|
||||
A minimalistic abstraction handling not only IO but also paths.
|
||||
|
||||
=item * L<IO::All|IO::All>
|
||||
|
||||
An attempt to expose as many IO related features as possible via a single API.
|
||||
|
||||
=item * L<File::Slurp|File::Slurp>
|
||||
|
||||
This is a previous generation file slurping module. It has a number of issues, as described L<here|http://blogs.perl.org/users/leon_timmermans/2015/08/fileslurp-is-broken-and-wrong.html>.
|
||||
|
||||
=item * L<File::Slurp::Tiny|File::Slurp::Tiny>
|
||||
|
||||
This was my previous attempt at a better file slurping module. It's mostly (but not entirely) a drop-in replacement for File::Slurp, which is both a feature (easy conversion) and a bug (interface issues).
|
||||
|
||||
=back
|
||||
|
||||
=head1 TODO
|
||||
|
||||
=over 4
|
||||
|
||||
=item * C<open_text>/C<open_binary>?
|
||||
|
||||
=item * C<drain_handle>?
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Leon Timmermans <leont@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2014 by Leon Timmermans.
|
||||
|
||||
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
|
||||
392
database/perl/vendor/lib/File/Which.pm
vendored
Normal file
392
database/perl/vendor/lib/File/Which.pm
vendored
Normal file
@@ -0,0 +1,392 @@
|
||||
package File::Which;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Exporter ();
|
||||
use File::Spec ();
|
||||
|
||||
# ABSTRACT: Perl implementation of the which utility as an API
|
||||
our $VERSION = '1.23'; # VERSION
|
||||
|
||||
|
||||
our @ISA = 'Exporter';
|
||||
our @EXPORT = 'which';
|
||||
our @EXPORT_OK = 'where';
|
||||
|
||||
use constant IS_VMS => ($^O eq 'VMS');
|
||||
use constant IS_MAC => ($^O eq 'MacOS');
|
||||
use constant IS_WIN => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
|
||||
use constant IS_DOS => IS_WIN();
|
||||
use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys');
|
||||
|
||||
our $IMPLICIT_CURRENT_DIR = IS_WIN || IS_VMS || IS_MAC;
|
||||
|
||||
# For Win32 systems, stores the extensions used for
|
||||
# executable files
|
||||
# For others, the empty string is used
|
||||
# because 'perl' . '' eq 'perl' => easier
|
||||
my @PATHEXT = ('');
|
||||
if ( IS_WIN ) {
|
||||
# WinNT. PATHEXT might be set on Cygwin, but not used.
|
||||
if ( $ENV{PATHEXT} ) {
|
||||
push @PATHEXT, split ';', $ENV{PATHEXT};
|
||||
} else {
|
||||
# Win9X or other: doesn't have PATHEXT, so needs hardcoded.
|
||||
push @PATHEXT, qw{.com .exe .bat};
|
||||
}
|
||||
} elsif ( IS_VMS ) {
|
||||
push @PATHEXT, qw{.exe .com};
|
||||
} elsif ( IS_CYG ) {
|
||||
# See this for more info
|
||||
# http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe
|
||||
push @PATHEXT, qw{.exe .com};
|
||||
}
|
||||
|
||||
|
||||
sub which {
|
||||
my ($exec) = @_;
|
||||
|
||||
return undef unless defined $exec;
|
||||
return undef if $exec eq '';
|
||||
|
||||
my $all = wantarray;
|
||||
my @results = ();
|
||||
|
||||
# check for aliases first
|
||||
if ( IS_VMS ) {
|
||||
my $symbol = `SHOW SYMBOL $exec`;
|
||||
chomp($symbol);
|
||||
unless ( $? ) {
|
||||
return $symbol unless $all;
|
||||
push @results, $symbol;
|
||||
}
|
||||
}
|
||||
if ( IS_MAC ) {
|
||||
my @aliases = split /\,/, $ENV{Aliases};
|
||||
foreach my $alias ( @aliases ) {
|
||||
# This has not been tested!!
|
||||
# PPT which says MPW-Perl cannot resolve `Alias $alias`,
|
||||
# let's just hope it's fixed
|
||||
if ( lc($alias) eq lc($exec) ) {
|
||||
chomp(my $file = `Alias $alias`);
|
||||
last unless $file; # if it failed, just go on the normal way
|
||||
return $file unless $all;
|
||||
push @results, $file;
|
||||
# we can stop this loop as if it finds more aliases matching,
|
||||
# it'll just be the same result anyway
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $exec
|
||||
if !IS_VMS and !IS_MAC and !IS_WIN and $exec =~ /\// and -f $exec and -x $exec;
|
||||
|
||||
my @path;
|
||||
if($^O eq 'MSWin32') {
|
||||
# File::Spec (at least recent versions)
|
||||
# add the implicit . for you on MSWin32,
|
||||
# but we may or may not want to include
|
||||
# that.
|
||||
@path = split(';', $ENV{PATH});
|
||||
s/"//g for @path;
|
||||
@path = grep length, @path;
|
||||
} else {
|
||||
@path = File::Spec->path;
|
||||
}
|
||||
if ( $IMPLICIT_CURRENT_DIR ) {
|
||||
unshift @path, File::Spec->curdir;
|
||||
}
|
||||
|
||||
foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) {
|
||||
for my $ext ( @PATHEXT ) {
|
||||
my $file = $base.$ext;
|
||||
|
||||
# We don't want dirs (as they are -x)
|
||||
next if -d $file;
|
||||
|
||||
if (
|
||||
# Executable, normal case
|
||||
-x _
|
||||
or (
|
||||
# MacOS doesn't mark as executable so we check -e
|
||||
IS_MAC
|
||||
||
|
||||
(
|
||||
( IS_WIN or IS_CYG )
|
||||
and
|
||||
grep {
|
||||
$file =~ /$_\z/i
|
||||
} @PATHEXT[1..$#PATHEXT]
|
||||
)
|
||||
# DOSish systems don't pass -x on
|
||||
# non-exe/bat/com files. so we check -e.
|
||||
# However, we don't want to pass -e on files
|
||||
# that aren't in PATHEXT, like README.
|
||||
and -e _
|
||||
)
|
||||
) {
|
||||
return $file unless $all;
|
||||
push @results, $file;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ( $all ) {
|
||||
return @results;
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub where {
|
||||
# force wantarray
|
||||
my @res = which($_[0]);
|
||||
return @res;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Which - Perl implementation of the which utility as an API
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.23
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Which; # exports which()
|
||||
use File::Which qw(which where); # exports which() and where()
|
||||
|
||||
my $exe_path = which 'perldoc';
|
||||
|
||||
my @paths = where 'perl';
|
||||
# Or
|
||||
my @paths = which 'perl'; # an array forces search for all of them
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<File::Which> finds the full or relative paths to executable programs on
|
||||
the system. This is normally the function of C<which> utility. C<which> is
|
||||
typically implemented as either a program or a built in shell command. On
|
||||
some platforms, such as Microsoft Windows it is not provided as part of the
|
||||
core operating system. This module provides a consistent API to this
|
||||
functionality regardless of the underlying platform.
|
||||
|
||||
The focus of this module is correctness and portability. As a consequence
|
||||
platforms where the current directory is implicitly part of the search path
|
||||
such as Microsoft Windows will find executables in the current directory,
|
||||
whereas on platforms such as UNIX where this is not the case executables
|
||||
in the current directory will only be found if the current directory is
|
||||
explicitly added to the path.
|
||||
|
||||
If you need a portable C<which> on the command line in an environment that
|
||||
does not provide it, install L<App::pwhich> which provides a command line
|
||||
interface to this API.
|
||||
|
||||
=head2 Implementations
|
||||
|
||||
L<File::Which> searches the directories of the user's C<PATH> (the current
|
||||
implementation uses L<File::Spec#path> to determine the correct C<PATH>),
|
||||
looking for executable files having the name specified as a parameter to
|
||||
L</which>. Under Win32 systems, which do not have a notion of directly
|
||||
executable files, but uses special extensions such as C<.exe> and C<.bat>
|
||||
to identify them, C<File::Which> takes extra steps to assure that
|
||||
you will find the correct file (so for example, you might be searching for
|
||||
C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.)
|
||||
|
||||
=head3 Linux, *BSD and other UNIXes
|
||||
|
||||
There should not be any surprises here. The current directory will not be
|
||||
searched unless it is explicitly added to the path.
|
||||
|
||||
=head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc)
|
||||
|
||||
Windows NT has a special environment variable called C<PATHEXT>, which is used
|
||||
by the shell to look for executable files. Usually, it will contain a list in
|
||||
the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an
|
||||
environment variable, it parses the list and uses it as the different
|
||||
extensions.
|
||||
|
||||
=head3 Cygwin
|
||||
|
||||
Cygwin provides a Unix-like environment for Microsoft Windows users. In most
|
||||
ways it works like other Unix and Unix-like environments, but in a few key
|
||||
aspects it works like Windows. As with other Unix environments, the current
|
||||
directory is not included in the search unless it is explicitly included in
|
||||
the search path. Like on Windows, files with C<.EXE> or <.BAT> extensions will
|
||||
be discovered even if they are not part of the query. C<.COM> or extensions
|
||||
specified using the C<PATHEXT> environment variable will NOT be discovered
|
||||
without the fully qualified name, however.
|
||||
|
||||
=head3 Windows ME, 98, 95, MS-DOS, OS/2
|
||||
|
||||
This set of operating systems don't have the C<PATHEXT> variable, and usually
|
||||
you will find executable files there with the extensions C<.exe>, C<.bat> and
|
||||
(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running
|
||||
under Win32 but does not find a C<PATHEXT> variable.
|
||||
|
||||
As of 2015 none of these platforms are tested frequently (or perhaps ever),
|
||||
but the current maintainer is determined not to intentionally remove support
|
||||
for older operating systems.
|
||||
|
||||
=head3 VMS
|
||||
|
||||
Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
|
||||
|
||||
As of 2015 the current maintainer does not test on VMS, and is in fact not
|
||||
certain it has ever been tested on VMS. If this platform is important to you
|
||||
and you can help me verify and or support it on that platform please contact
|
||||
me.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 which
|
||||
|
||||
my $path = which $short_exe_name;
|
||||
my @paths = which $short_exe_name;
|
||||
|
||||
Exported by default.
|
||||
|
||||
C<$short_exe_name> is the name used in the shell to call the program (for
|
||||
example, C<perl>).
|
||||
|
||||
If it finds an executable with the name you specified, C<which()> will return
|
||||
the absolute path leading to this executable (for example, F</usr/bin/perl> or
|
||||
F<C:\Perl\Bin\perl.exe>).
|
||||
|
||||
If it does I<not> find the executable, it returns C<undef>.
|
||||
|
||||
If C<which()> is called in list context, it will return I<all> the
|
||||
matches.
|
||||
|
||||
=head2 where
|
||||
|
||||
my @paths = where $short_exe_name;
|
||||
|
||||
Not exported by default.
|
||||
|
||||
Same as L</which> in array context. Similar to the C<where> csh
|
||||
built-in command or C<which -a> command for platforms that support the
|
||||
C<-a> option. Will return an array containing all the path names
|
||||
matching C<$short_exe_name>.
|
||||
|
||||
=head1 GLOBALS
|
||||
|
||||
=head2 $IMPLICIT_CURRENT_DIR
|
||||
|
||||
True if the current directory is included in the search implicitly on
|
||||
whatever platform you are using. Normally the default is reasonable,
|
||||
but on Windows the current directory is included implicitly for older
|
||||
shells like C<cmd.exe> and C<command.com>, but not for newer shells
|
||||
like PowerShell. If you overrule this default, you should ALWAYS
|
||||
localize the variable to the tightest scope possible, since setting
|
||||
this variable from a module can affect other modules. Thus on Windows
|
||||
you can get the correct result if the user is running either C<cmd.exe>
|
||||
or PowerShell on Windows you can do this:
|
||||
|
||||
use File::Which qw( which );
|
||||
use Shell::Guess;
|
||||
|
||||
my $path = do {
|
||||
my $is_power = Shell::Guess->running_shell->is_power;
|
||||
local $File::Which::IMPLICIT_CURRENT_DIR = !$is_power;
|
||||
which 'foo';
|
||||
};
|
||||
|
||||
For a variety of reasons it is difficult to accurately compute the
|
||||
shell that a user is using, but L<Shell::Guess> makes a reasonable
|
||||
effort.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
This module has no non-core requirements for Perl 5.6.2 and better.
|
||||
|
||||
This module is fully supported back to Perl 5.8.1. It may work on 5.8.0.
|
||||
It should work on Perl 5.6.x and I may even test on 5.6.2. I will accept
|
||||
patches to maintain compatibility for such older Perls, but you may
|
||||
need to fix it on 5.6.x / 5.8.0 and send me a patch.
|
||||
|
||||
Not tested on VMS although there is platform specific code
|
||||
for those. Anyone who haves a second would be very kind to send me a
|
||||
report of how it went.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs should be reported via the GitHub issue tracker
|
||||
|
||||
L<https://github.com/plicease/File-Which/issues>
|
||||
|
||||
For other issues, contact the maintainer.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<pwhich>, L<App::pwhich>
|
||||
|
||||
Command line interface to this module.
|
||||
|
||||
=item L<IPC::Cmd>
|
||||
|
||||
This module provides (among other things) a C<can_run> function, which is
|
||||
similar to C<which>. It is a much heavier module since it does a lot more,
|
||||
and if you use C<can_run> it pulls in L<ExtUtils::MakeMaker>. This combination
|
||||
may be overkill for applications which do not need L<IPC::Cmd>'s complicated
|
||||
interface for running programs, or do not need the memory overhead required
|
||||
for installing Perl modules.
|
||||
|
||||
At least some older versions will find executables in the current directory,
|
||||
even if the current directory is not in the search path (which is the default
|
||||
on modern Unix).
|
||||
|
||||
C<can_run> converts directory path name to the 8.3 version on Windows using
|
||||
C<Win32::GetShortPathName> in some cases. This is frequently useful for tools
|
||||
that just need to run something using C<system> in scalar mode, but may be
|
||||
inconvenient for tools like L<App::pwhich> where user readability is a premium.
|
||||
Relying on C<Win32::GetShortPathName> to produce filenames without spaces
|
||||
is problematic, as 8.3 filenames can be turned off with tweaks to the
|
||||
registry (see L<https://technet.microsoft.com/en-us/library/cc959352.aspx>).
|
||||
|
||||
=item L<Devel::CheckBin>
|
||||
|
||||
This module purports to "check that a command is available", but does not
|
||||
provide any documentation on how you might use it.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Per Einar Ellefsen <pereinar@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Adam Kennedy <adamk@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Graham Ollis <plicease@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2002 by Per Einar Ellefsen <pereinar@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
|
||||
460
database/perl/vendor/lib/File/chdir.pm
vendored
Normal file
460
database/perl/vendor/lib/File/chdir.pm
vendored
Normal file
@@ -0,0 +1,460 @@
|
||||
package File::chdir;
|
||||
use 5.004;
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT $CWD @CWD);
|
||||
# ABSTRACT: a more sensible way to change directories
|
||||
|
||||
our $VERSION = '0.1010';
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(*CWD);
|
||||
|
||||
use Carp;
|
||||
use Cwd 3.16;
|
||||
use File::Spec::Functions 3.27 qw/canonpath splitpath catpath splitdir catdir/;
|
||||
|
||||
tie $CWD, 'File::chdir::SCALAR' or die "Can't tie \$CWD";
|
||||
tie @CWD, 'File::chdir::ARRAY' or die "Can't tie \@CWD";
|
||||
|
||||
sub _abs_path {
|
||||
# Otherwise we'll never work under taint mode.
|
||||
my($cwd) = Cwd::getcwd =~ /(.*)/s;
|
||||
# Run through File::Spec, since everything else uses it
|
||||
return canonpath($cwd);
|
||||
}
|
||||
|
||||
# splitpath but also split directory
|
||||
sub _split_cwd {
|
||||
my ($vol, $dir) = splitpath(_abs_path, 1);
|
||||
my @dirs = splitdir( $dir );
|
||||
shift @dirs; # get rid of leading empty "root" directory
|
||||
return ($vol, @dirs);
|
||||
}
|
||||
|
||||
# catpath, but take list of directories
|
||||
# restore the empty root dir and provide an empty file to avoid warnings
|
||||
sub _catpath {
|
||||
my ($vol, @dirs) = @_;
|
||||
return catpath($vol, catdir(q{}, @dirs), q{});
|
||||
}
|
||||
|
||||
sub _chdir {
|
||||
# Untaint target directory
|
||||
my ($new_dir) = $_[0] =~ /(.*)/s;
|
||||
|
||||
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
|
||||
if ( ! CORE::chdir($new_dir) ) {
|
||||
croak "Failed to change directory to '$new_dir': $!";
|
||||
};
|
||||
return 1;
|
||||
}
|
||||
|
||||
{
|
||||
package File::chdir::SCALAR;
|
||||
use Carp;
|
||||
|
||||
BEGIN {
|
||||
*_abs_path = \&File::chdir::_abs_path;
|
||||
*_chdir = \&File::chdir::_chdir;
|
||||
*_split_cwd = \&File::chdir::_split_cwd;
|
||||
*_catpath = \&File::chdir::_catpath;
|
||||
}
|
||||
|
||||
sub TIESCALAR {
|
||||
bless [], $_[0];
|
||||
}
|
||||
|
||||
# To be safe, in case someone chdir'd out from under us, we always
|
||||
# check the Cwd explicitly.
|
||||
sub FETCH {
|
||||
return _abs_path;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
return unless defined $_[1];
|
||||
_chdir($_[1]);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
package File::chdir::ARRAY;
|
||||
use Carp;
|
||||
|
||||
BEGIN {
|
||||
*_abs_path = \&File::chdir::_abs_path;
|
||||
*_chdir = \&File::chdir::_chdir;
|
||||
*_split_cwd = \&File::chdir::_split_cwd;
|
||||
*_catpath = \&File::chdir::_catpath;
|
||||
}
|
||||
|
||||
sub TIEARRAY {
|
||||
bless {}, $_[0];
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my($self, $idx) = @_;
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
return $cwd[$idx];
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my($self, $idx, $val) = @_;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
if( $self->{Cleared} ) {
|
||||
@cwd = ();
|
||||
$self->{Cleared} = 0;
|
||||
}
|
||||
|
||||
$cwd[$idx] = $val;
|
||||
my $dir = _catpath($vol,@cwd);
|
||||
|
||||
_chdir($dir);
|
||||
return $cwd[$idx];
|
||||
}
|
||||
|
||||
sub FETCHSIZE {
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
return scalar @cwd;
|
||||
}
|
||||
sub STORESIZE {}
|
||||
|
||||
sub PUSH {
|
||||
my($self) = shift;
|
||||
|
||||
my $dir = _catpath(_split_cwd, @_);
|
||||
_chdir($dir);
|
||||
return $self->FETCHSIZE;
|
||||
}
|
||||
|
||||
sub POP {
|
||||
my($self) = shift;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my $popped = pop @cwd;
|
||||
my $dir = _catpath($vol,@cwd);
|
||||
_chdir($dir);
|
||||
return $popped;
|
||||
}
|
||||
|
||||
sub SHIFT {
|
||||
my($self) = shift;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my $shifted = shift @cwd;
|
||||
my $dir = _catpath($vol,@cwd);
|
||||
_chdir($dir);
|
||||
return $shifted;
|
||||
}
|
||||
|
||||
sub UNSHIFT {
|
||||
my($self) = shift;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my $dir = _catpath($vol, @_, @cwd);
|
||||
_chdir($dir);
|
||||
return $self->FETCHSIZE;
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my($self) = shift;
|
||||
$self->{Cleared} = 1;
|
||||
}
|
||||
|
||||
sub SPLICE {
|
||||
my $self = shift;
|
||||
my $offset = shift || 0;
|
||||
my $len = shift || $self->FETCHSIZE - $offset;
|
||||
my @new_dirs = @_;
|
||||
|
||||
my ($vol, @cwd) = _split_cwd;
|
||||
my @orig_dirs = splice @cwd, $offset, $len, @new_dirs;
|
||||
my $dir = _catpath($vol, @cwd);
|
||||
_chdir($dir);
|
||||
return @orig_dirs;
|
||||
}
|
||||
|
||||
sub EXTEND { }
|
||||
sub EXISTS {
|
||||
my($self, $idx) = @_;
|
||||
return $self->FETCHSIZE >= $idx ? 1 : 0;
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my($self, $idx) = @_;
|
||||
croak "Can't delete except at the end of \@CWD"
|
||||
if $idx < $self->FETCHSIZE - 1;
|
||||
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
|
||||
$self->POP;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::chdir - a more sensible way to change directories
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.1010
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::chdir;
|
||||
|
||||
$CWD = "/foo/bar"; # now in /foo/bar
|
||||
{
|
||||
local $CWD = "/moo/baz"; # now in /moo/baz
|
||||
...
|
||||
}
|
||||
|
||||
# still in /foo/bar!
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Perl's C<chdir()> has the unfortunate problem of being very, very, very
|
||||
global. If any part of your program calls C<chdir()> or if any library
|
||||
you use calls C<chdir()>, it changes the current working directory for
|
||||
the *whole* program.
|
||||
|
||||
This sucks.
|
||||
|
||||
File::chdir gives you an alternative, C<$CWD> and C<@CWD>. These two
|
||||
variables combine all the power of C<chdir()>, L<File::Spec> and L<Cwd>.
|
||||
|
||||
=head1 $CWD
|
||||
|
||||
Use the C<$CWD> variable instead of C<chdir()> and Cwd.
|
||||
|
||||
use File::chdir;
|
||||
$CWD = $dir; # just like chdir($dir)!
|
||||
print $CWD; # prints the current working directory
|
||||
|
||||
It can be localized, and it does the right thing.
|
||||
|
||||
$CWD = "/foo"; # it's /foo out here.
|
||||
{
|
||||
local $CWD = "/bar"; # /bar in here
|
||||
}
|
||||
# still /foo out here!
|
||||
|
||||
C<$CWD> always returns the absolute path in the native form for the
|
||||
operating system.
|
||||
|
||||
C<$CWD> and normal C<chdir()> work together just fine.
|
||||
|
||||
=head1 @CWD
|
||||
|
||||
C<@CWD> represents the current working directory as an array, each
|
||||
directory in the path is an element of the array. This can often make
|
||||
the directory easier to manipulate, and you don't have to fumble with
|
||||
C<File::Spec->splitpath> and C<File::Spec->catdir> to make portable code.
|
||||
|
||||
# Similar to chdir("/usr/local/src/perl")
|
||||
@CWD = qw(usr local src perl);
|
||||
|
||||
pop, push, shift, unshift and splice all work. pop and push are
|
||||
probably the most useful.
|
||||
|
||||
pop @CWD; # same as chdir(File::Spec->updir)
|
||||
push @CWD, 'some_dir' # same as chdir('some_dir')
|
||||
|
||||
C<@CWD> and C<$CWD> both work fine together.
|
||||
|
||||
*NOTE* Due to a perl bug you can't localize C<@CWD>. See L</CAVEATS> for a work around.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
(We omit the C<use File::chdir> from these examples for terseness)
|
||||
|
||||
Here's C<$CWD> instead of C<chdir()>:
|
||||
|
||||
$CWD = 'foo'; # chdir('foo')
|
||||
|
||||
and now instead of Cwd.
|
||||
|
||||
print $CWD; # use Cwd; print Cwd::abs_path
|
||||
|
||||
you can even do zsh style C<cd foo bar>
|
||||
|
||||
$CWD = '/usr/local/foo';
|
||||
$CWD =~ s/usr/var/;
|
||||
|
||||
if you want to localize that, make sure you get the parens right
|
||||
|
||||
{
|
||||
(local $CWD) =~ s/usr/var/;
|
||||
...
|
||||
}
|
||||
|
||||
It's most useful for writing polite subroutines which don't leave the
|
||||
program in some strange directory:
|
||||
|
||||
sub foo {
|
||||
local $CWD = 'some/other/dir';
|
||||
...do your work...
|
||||
}
|
||||
|
||||
which is much simpler than the equivalent:
|
||||
|
||||
sub foo {
|
||||
use Cwd;
|
||||
my $orig_dir = Cwd::getcwd;
|
||||
chdir('some/other/dir');
|
||||
|
||||
...do your work...
|
||||
|
||||
chdir($orig_dir);
|
||||
}
|
||||
|
||||
C<@CWD> comes in handy when you want to start moving up and down the
|
||||
directory hierarchy in a cross-platform manner without having to use
|
||||
File::Spec.
|
||||
|
||||
pop @CWD; # chdir(File::Spec->updir);
|
||||
push @CWD, 'some', 'dir' # chdir(File::Spec->catdir(qw(some dir)));
|
||||
|
||||
You can easily change your parent directory:
|
||||
|
||||
# chdir from /some/dir/bar/moo to /some/dir/foo/moo
|
||||
$CWD[-2] = 'foo';
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
=head2 C<local @CWD> does not work.
|
||||
|
||||
C<local @CWD> will not localize C<@CWD>. This is a bug in Perl, you
|
||||
can't localize tied arrays. As a work around localizing $CWD will
|
||||
effectively localize @CWD.
|
||||
|
||||
{
|
||||
local $CWD;
|
||||
pop @CWD;
|
||||
...
|
||||
}
|
||||
|
||||
=head2 Assigning to C<@CWD> calls C<chdir()> for each element
|
||||
|
||||
@CWD = qw/a b c d/;
|
||||
|
||||
Internally, Perl clears C<@CWD> and assigns each element in turn. Thus, this
|
||||
code above will do this:
|
||||
|
||||
chdir 'a';
|
||||
chdir 'a/b';
|
||||
chdir 'a/b/c';
|
||||
chdir 'a/b/c/d';
|
||||
|
||||
Generally, avoid assigning to C<@CWD> and just use push and pop instead.
|
||||
|
||||
=head2 Volumes not handled
|
||||
|
||||
There is currently no way to change the current volume via File::chdir.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
C<$CWD> returns the current directory using native path separators, i.e. \
|
||||
on Win32. This ensures that C<$CWD> will compare correctly with directories
|
||||
created using File::Spec. For example:
|
||||
|
||||
my $working_dir = File::Spec->catdir( $CWD, "foo" );
|
||||
$CWD = $working_dir;
|
||||
doing_stuff_might_chdir();
|
||||
is( $CWD, $working_dir, "back to original working_dir?" );
|
||||
|
||||
Deleting the last item of C<@CWD> will act like a pop. Deleting from the
|
||||
middle will throw an exception.
|
||||
|
||||
delete @CWD[-1]; # OK
|
||||
delete @CWD[-2]; # Dies
|
||||
|
||||
What should %CWD do? Something with volumes?
|
||||
|
||||
# chdir to C:\Program Files\Sierra\Half Life ?
|
||||
$CWD{C} = '\\Program Files\\Sierra\\Half Life';
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If an error is encountered when changing C<$CWD> or C<@CWD>, one of
|
||||
the following exceptions will be thrown:
|
||||
|
||||
* ~Can't delete except at the end of @CWD~
|
||||
* ~Failed to change directory to '$dir'~
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
Michael wanted C<local chdir> to work. p5p didn't. But it wasn't over!
|
||||
Was it over when the Germans bombed Pearl Harbor? Hell, no!
|
||||
|
||||
Abigail and/or Bryan Warnock suggested the C<$CWD> thing (Michael forgets
|
||||
which). They were right.
|
||||
|
||||
The C<chdir()> override was eliminated in 0.04.
|
||||
|
||||
David became co-maintainer with 0.06_01 to fix some chronic
|
||||
Win32 path bugs.
|
||||
|
||||
As of 0.08, if changing C<$CWD> or C<@CWD> fails to change the directory, an
|
||||
error will be thrown.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::pushd>, L<File::Spec>, L<Cwd>, L<perlfunc/chdir>,
|
||||
"Animal House" L<http://www.imdb.com/title/tt0077975/quotes>
|
||||
|
||||
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests through the issue tracker
|
||||
at L<https://github.com/dagolden/File-chdir/issues>.
|
||||
You will be notified automatically of any progress on your issue.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
This is open source software. The code repository is available for
|
||||
public review and contribution under the terms of the license.
|
||||
|
||||
L<https://github.com/dagolden/File-chdir>
|
||||
|
||||
git clone https://github.com/dagolden/File-chdir.git
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Michael G. Schwern <schwern@pobox.com>
|
||||
|
||||
=back
|
||||
|
||||
=head1 CONTRIBUTOR
|
||||
|
||||
=for stopwords Joel Berger
|
||||
|
||||
Joel Berger <joel.a.berger@gmail.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2015 by Michael G. Schwern and David Golden.
|
||||
|
||||
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
|
||||
Reference in New Issue
Block a user