###################### # SIMPLE FILES::Spec # ###################### package LibZip::File::Spec ; #use strict qw( vars subs ) ; no warnings ; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', os2 => 'OS2', VMS => 'VMS', epoc => 'Unix', NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. cygwin => 'Unix'); my $module = $module{$^O} || 'Unix'; sub splitpath { &{"splitpath_$module"}(@_); } ; sub catpath { &{"catpath_$module"}(@_); } ; sub splitpath_Unix { my ($self,$path, $nofile) = @_; my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { $directory = $path; } else { $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs; $directory = $1; $file = $2; } return ($volume,$directory,$file); } sub catpath_Unix { my ($self,$volume,$directory,$file) = @_; if ( $directory ne '' && $file ne '' && substr( $directory, -1 ) ne '/' && substr( $file, 0, 1 ) ne '/' ) { $directory .= "/$file" ; } else { $directory .= $file ; } return $directory ; } sub splitpath_Win32 { my ($self,$path, $nofile) = @_; my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { $path =~ m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) (.*) }xs; $volume = $1; $directory = $2; } else { $path =~ m{^ ( (?: [a-zA-Z]: | (?:\\\\|//)[^\\/]+[\\/][^\\/]+ )? ) ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) (.*) }xs; $volume = $1; $directory = $2; $file = $3; } return ($volume,$directory,$file); } sub catpath_Win32 { my ($self,$volume,$directory,$file) = @_; # If it's UNC, make sure the glue separator is there, reusing # whatever separator is first in the $volume $volume .= $1 if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && $directory =~ m@^[^\\/]@s ) ; $volume .= $directory ; # If the volume is not just A:, make sure the glue separator is # there, reusing whatever separator is first in the $volume if possible. if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && $volume =~ m@[^\\/]\Z(?!\n)@ && $file =~ m@[^\\/]@ ) { $volume =~ m@([\\/])@ ; my $sep = $1 ? $1 : '\\' ; $volume .= $sep ; } $volume .= $file ; return $volume ; } sub splitpath_Mac { my ($self,$path, $nofile) = @_; my ($volume,$directory,$file); if ( $nofile ) { ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s; } else { $path =~ m|^( (?: [^:]+: )? ) ( (?: .*: )? ) ( .* ) |xs; $volume = $1; $directory = $2; $file = $3; } $volume = '' unless defined($volume); $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir" if ($directory) { # Make sure non-empty directories begin and end in ':' $directory .= ':' unless (substr($directory,-1) eq ':'); $directory = ":$directory" unless (substr($directory,0,1) eq ':'); } else { $directory = ''; } $file = '' unless defined($file); return ($volume,$directory,$file); } sub catpath_Mac { my ($self,$volume,$directory,$file) = @_; if ( (! $volume) && (! $directory) ) { $file =~ s/^:// if $file; return $file ; } my $path = $volume; # may be '' $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' if ($directory) { $directory =~ s/^://; # remove leading ':' if any $path .= $directory; $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' } if ($file) { $file =~ s/^://; # remove leading ':' if any $path .= $file; } return $path; } sub splitpath_OS2 { my ($self,$path, $nofile) = @_; my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { $path =~ m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) (.*) }xs; $volume = $1; $directory = $2; } else { $path =~ m{^ ( (?: [a-zA-Z]: | (?:\\\\|//)[^\\/]+[\\/][^\\/]+ )? ) ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) (.*) }xs; $volume = $1; $directory = $2; $file = $3; } return ($volume,$directory,$file); } sub catpath_OS2 { my ($self,$volume,$directory,$file) = @_; # If it's UNC, make sure the glue separator is there, reusing # whatever separator is first in the $volume $volume .= $1 if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && $directory =~ m@^[^\\/]@s ) ; $volume .= $directory ; # If the volume is not just A:, make sure the glue separator is # there, reusing whatever separator is first in the $volume if possible. if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && $volume =~ m@[^\\/]\Z(?!\n)@ && $file =~ m@[^\\/]@ ) { $volume =~ m@([\\/])@ ; my $sep = $1 ? $1 : '/' ; $volume .= $sep ; } $volume .= $file ; return $volume ; } sub splitpath_VMS { my($self,$path) = @_; my($dev,$dir,$file) = ('','',''); vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; return ($1 || '',$2 || '',$3); } sub catpath_VMS { my($self,$dev,$dir,$file) = @_; if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } if (length($dev) or length($dir)) { $dir = "[$dir]" unless $dir =~ /[\[<\/]/; $dir = vmspath($dir); } "$dev$dir$file"; } ########################## # LIBZIP::FILE::BASENAME # ########################## package LibZip::File::Basename ; my(@ISA, $VERSION, $Fileparse_fstype, $Fileparse_igncase); $VERSION = "2.71"; sub fileparse { my($fullname,@suffices) = @_; my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); my($dirpath,$tail,$suffix,$basename); my($taint) = substr($fullname,0,0); # Is $fullname tainted? if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); $dirpath ||= ''; # should always be defined } } if ($fstype =~ /^MS(DOS|Win32)|epoc/i) { ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; } elsif ($fstype =~ /^os2/i) { ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); $dirpath = './' unless $dirpath; # Can't be 0 $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; } elsif ($fstype =~ /^MacOS/si) { ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); $dirpath = ':' unless $dirpath; } elsif ($fstype =~ /^AmigaOS/i) { ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); $dirpath = './' unless $dirpath; } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) { # dev:[000000] is top of VMS tree, similar to Unix '/' # so strip it off and treat the rest as "normal" my $devspec = $1; my $remainder = $3; ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s); $dirpath ||= ''; # should always be defined $dirpath = $devspec.$dirpath; } $dirpath = './' unless $dirpath; } if (@suffices) { $tail = ''; foreach $suffix (@suffices) { my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; if ($basename =~ s/$pat//s) { $taint .= substr($suffix,0,0); $tail = $1 . $tail; } } } $tail .= $taint if defined $tail; # avoid warning if $tail == undef wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) : ($basename .= $taint); } sub dirname { my($basename,$dirname) = fileparse($_[0]); my($fstype) = $Fileparse_fstype; if ($fstype =~ /VMS/i) { if ($_[0] =~ m#/#) { $fstype = '' } else { return $dirname || $ENV{DEFAULT} } } if ($fstype =~ /MacOS/i) { if( !length($basename) && $dirname !~ /^[^:]+:\z/) { $dirname =~ s/([^:]):\z/$1/s; ($basename,$dirname) = fileparse $dirname; } $dirname .= ":" unless $dirname =~ /:\z/; } elsif ($fstype =~ /MS(DOS|Win32)|os2/i) { $dirname =~ s/([^:])[\\\/]*\z/$1/; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; $dirname =~ s/([^:])[\\\/]*\z/$1/; } } elsif ($fstype =~ /AmigaOS/i) { if ( $dirname =~ /:\z/) { return $dirname } chop $dirname; $dirname =~ s#[^:/]+\z## unless length($basename); } else { $dirname =~ s:(.)/*\z:$1:s; unless( length($basename) ) { local($LibZip::File::Basename::Fileparse_fstype) = $fstype; ($basename,$dirname) = fileparse $dirname; $dirname =~ s:(.)/*\z:$1:s; } } $dirname; } sub fileparse_set_fstype { my @old = ($Fileparse_fstype, $Fileparse_igncase); if (@_) { $Fileparse_fstype = $_[0]; $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i); } wantarray ? @old : $old[0]; } fileparse_set_fstype $^O; #################### # LIBZIPFILE::PATH # #################### package LibZip::File::Path ; my $Is_VMS = $^O eq 'VMS'; my $Is_MacOS = $^O eq 'MacOS'; sub mkpath { my($paths, $verbose, $mode) = @_; # $paths -- either a path string or ref to list of paths # $verbose -- optional print "mkdir $path" for each directory created # $mode -- optional permissions, defaults to 0777 local($")=$Is_MacOS ? ":" : "/"; $mode = 0777 unless defined($mode); $paths = [$paths] unless ref $paths; my(@created,$path); foreach $path (@$paths) { $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT # Logic wants Unix paths, so go with the flow. next if -d $path; my $parent = LibZip::File::Basename::dirname($path); unless (-d $parent or $path eq $parent) { push(@created,mkpath($parent, $verbose, $mode)); } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { my $e = $!; # allow for another process to have created it meanwhile #croak "mkdir $path: $e" unless -d $path; } push(@created, $path); } @created; } sub carp { warn join("\n", @_) . "\n" if !$LibZip::END ; } sub rmtree { my($roots, $verbose, $safe) = @_; my(@files); my($count) = 0; $verbose ||= 0; $safe ||= 0; if ( defined($roots) && length($roots) ) { $roots = [$roots] unless ref $roots; } else { carp "No root path(s) specified\n"; return 0; } my($root); foreach $root (@{$roots}) { if ($Is_MacOS) { $root = ":$root" if $root !~ /:/; $root =~ s#([^:])\z#$1:#; } else { $root =~ s#/\z##; } (undef, undef, my $rp) = lstat $root or next; $rp &= 07777; # don't forget setuid, setgid, sticky bits if ( -d _ ) { # notabene: 0777 is for making readable in the first place, # it's also intended to change it to writable in case we have # to recurse in which case we are better than rm -rf for # subtrees with strange permissions chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) or carp "Can't make directory $root read+writeable: $!" unless $safe; if (opendir my $d, $root) { #no strict 'refs'; if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { # Blindly untaint dir names @files = map { /^(.*)$/s ; $1 } readdir $d; } else { @files = readdir $d; } closedir $d; } else { carp "Can't read $root: $!"; @files = (); } # Deleting large numbers of files from VMS Files-11 filesystems # is faster if done in reverse ASCIIbetical order @files = reverse @files if $Is_VMS; ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; if ($Is_MacOS) { @files = map("$root$_", @files); } else { @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); } $count += rmtree(\@files,$verbose,$safe); if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { print "skipped $root\n" if $verbose; next; } chmod 0777, $root or carp "Can't make directory $root writeable: $!" if $force_writeable; print "rmdir $root\n" if $verbose; if (rmdir $root) { ++$count; } else { carp "Can't remove directory $root: $!"; chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) or carp("and can't restore permissions to " . sprintf("0%o",$rp) . "\n"); } } else { if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !(-l $root || -w $root))) { print "skipped $root\n" if $verbose; next; } chmod 0666, $root or carp "Can't make file $root writeable: $!" if $force_writeable; print "unlink $root\n" if $verbose; # delete all versions under VMS for (;;) { unless (unlink $root) { carp "Can't unlink file $root: $!"; if ($force_writeable) { chmod $rp, $root or carp("and can't restore permissions to " . sprintf("0%o",$rp) . "\n"); } last; } ++$count; last unless $Is_VMS && lstat $root; } } } $count; } # my ( $volumeName, $dirName, $fileName ) = LibZip::File::Spec->splitpath('./LibZipData.pm'); # print "$volumeName, $dirName, $fileName\n" ; # # $dirName = LibZip::File::Spec->catpath( $volumeName, $dirName, '' ); # print "$dirName\n" ; # # my $d = LibZip::File::Basename::dirname('./asdasd/fl.txt') ; # print "$d\n" ; ####### # END # ####### 1;