"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/ExtUtils/Command.pm" (10 Mar 2019, 7802 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package ExtUtils::Command;
    2 
    3 use 5.00503;
    4 use strict;
    5 require Exporter;
    6 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
    7 @ISA       = qw(Exporter);
    8 @EXPORT    = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
    9                 dos2unix);
   10 $VERSION = '7.34';
   11 $VERSION = eval $VERSION;
   12 
   13 my $Is_VMS   = $^O eq 'VMS';
   14 my $Is_VMS_mode = $Is_VMS;
   15 my $Is_VMS_noefs = $Is_VMS;
   16 my $Is_Win32 = $^O eq 'MSWin32';
   17 
   18 if( $Is_VMS ) {
   19     my $vms_unix_rpt;
   20     my $vms_efs;
   21     my $vms_case;
   22 
   23     if (eval { local $SIG{__DIE__};
   24                local @INC = @INC;
   25                pop @INC if $INC[-1] eq '.';
   26                require VMS::Feature; }) {
   27         $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
   28         $vms_efs = VMS::Feature::current("efs_charset");
   29         $vms_case = VMS::Feature::current("efs_case_preserve");
   30     } else {
   31         my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
   32         my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
   33         my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
   34         $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
   35         $vms_efs = $efs_charset =~ /^[ET1]/i;
   36         $vms_case = $efs_case =~ /^[ET1]/i;
   37     }
   38     $Is_VMS_mode = 0 if $vms_unix_rpt;
   39     $Is_VMS_noefs = 0 if ($vms_efs);
   40 }
   41 
   42 
   43 =head1 NAME
   44 
   45 ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
   46 
   47 =head1 SYNOPSIS
   48 
   49   perl -MExtUtils::Command -e cat files... > destination
   50   perl -MExtUtils::Command -e mv source... destination
   51   perl -MExtUtils::Command -e cp source... destination
   52   perl -MExtUtils::Command -e touch files...
   53   perl -MExtUtils::Command -e rm_f files...
   54   perl -MExtUtils::Command -e rm_rf directories...
   55   perl -MExtUtils::Command -e mkpath directories...
   56   perl -MExtUtils::Command -e eqtime source destination
   57   perl -MExtUtils::Command -e test_f file
   58   perl -MExtUtils::Command -e test_d directory
   59   perl -MExtUtils::Command -e chmod mode files...
   60   ...
   61 
   62 =head1 DESCRIPTION
   63 
   64 The module is used to replace common UNIX commands.  In all cases the
   65 functions work from @ARGV rather than taking arguments.  This makes
   66 them easier to deal with in Makefiles.  Call them like this:
   67 
   68   perl -MExtUtils::Command -e some_command some files to work on
   69 
   70 and I<NOT> like this:
   71 
   72   perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
   73 
   74 For that use L<Shell::Command>.
   75 
   76 Filenames with * and ? will be glob expanded.
   77 
   78 
   79 =head2 FUNCTIONS
   80 
   81 =over 4
   82 
   83 =cut
   84 
   85 # VMS uses % instead of ? to mean "one character"
   86 my $wild_regex = $Is_VMS ? '*%' : '*?';
   87 sub expand_wildcards
   88 {
   89  @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
   90 }
   91 
   92 
   93 =item cat
   94 
   95     cat file ...
   96 
   97 Concatenates all files mentioned on command line to STDOUT.
   98 
   99 =cut
  100 
  101 sub cat ()
  102 {
  103  expand_wildcards();
  104  print while (<>);
  105 }
  106 
  107 =item eqtime
  108 
  109     eqtime source destination
  110 
  111 Sets modified time of destination to that of source.
  112 
  113 =cut
  114 
  115 sub eqtime
  116 {
  117  my ($src,$dst) = @ARGV;
  118  local @ARGV = ($dst);  touch();  # in case $dst doesn't exist
  119  utime((stat($src))[8,9],$dst);
  120 }
  121 
  122 =item rm_rf
  123 
  124     rm_rf files or directories ...
  125 
  126 Removes files and directories - recursively (even if readonly)
  127 
  128 =cut
  129 
  130 sub rm_rf
  131 {
  132  expand_wildcards();
  133  require File::Path;
  134  File::Path::rmtree([grep -e $_,@ARGV],0,0);
  135 }
  136 
  137 =item rm_f
  138 
  139     rm_f file ...
  140 
  141 Removes files (even if readonly)
  142 
  143 =cut
  144 
  145 sub rm_f {
  146     expand_wildcards();
  147 
  148     foreach my $file (@ARGV) {
  149         next unless -f $file;
  150 
  151         next if _unlink($file);
  152 
  153         chmod(0777, $file);
  154 
  155         next if _unlink($file);
  156 
  157         require Carp;
  158         Carp::carp("Cannot delete $file: $!");
  159     }
  160 }
  161 
  162 sub _unlink {
  163     my $files_unlinked = 0;
  164     foreach my $file (@_) {
  165         my $delete_count = 0;
  166         $delete_count++ while unlink $file;
  167         $files_unlinked++ if $delete_count;
  168     }
  169     return $files_unlinked;
  170 }
  171 
  172 
  173 =item touch
  174 
  175     touch file ...
  176 
  177 Makes files exist, with current timestamp
  178 
  179 =cut
  180 
  181 sub touch {
  182     my $t    = time;
  183     expand_wildcards();
  184     foreach my $file (@ARGV) {
  185         open(FILE,">>$file") || die "Cannot write $file:$!";
  186         close(FILE);
  187         utime($t,$t,$file);
  188     }
  189 }
  190 
  191 =item mv
  192 
  193     mv source_file destination_file
  194     mv source_file source_file destination_dir
  195 
  196 Moves source to destination.  Multiple sources are allowed if
  197 destination is an existing directory.
  198 
  199 Returns true if all moves succeeded, false otherwise.
  200 
  201 =cut
  202 
  203 sub mv {
  204     expand_wildcards();
  205     my @src = @ARGV;
  206     my $dst = pop @src;
  207 
  208     if (@src > 1 && ! -d $dst) {
  209         require Carp;
  210         Carp::croak("Too many arguments");
  211     }
  212 
  213     require File::Copy;
  214     my $nok = 0;
  215     foreach my $src (@src) {
  216         $nok ||= !File::Copy::move($src,$dst);
  217     }
  218     return !$nok;
  219 }
  220 
  221 =item cp
  222 
  223     cp source_file destination_file
  224     cp source_file source_file destination_dir
  225 
  226 Copies sources to the destination.  Multiple sources are allowed if
  227 destination is an existing directory.
  228 
  229 Returns true if all copies succeeded, false otherwise.
  230 
  231 =cut
  232 
  233 sub cp {
  234     expand_wildcards();
  235     my @src = @ARGV;
  236     my $dst = pop @src;
  237 
  238     if (@src > 1 && ! -d $dst) {
  239         require Carp;
  240         Carp::croak("Too many arguments");
  241     }
  242 
  243     require File::Copy;
  244     my $nok = 0;
  245     foreach my $src (@src) {
  246         $nok ||= !File::Copy::copy($src,$dst);
  247 
  248         # Win32 does not update the mod time of a copied file, just the
  249         # created time which make does not look at.
  250         utime(time, time, $dst) if $Is_Win32;
  251     }
  252     return $nok;
  253 }
  254 
  255 =item chmod
  256 
  257     chmod mode files ...
  258 
  259 Sets UNIX like permissions 'mode' on all the files.  e.g. 0666
  260 
  261 =cut
  262 
  263 sub chmod {
  264     local @ARGV = @ARGV;
  265     my $mode = shift(@ARGV);
  266     expand_wildcards();
  267 
  268     if( $Is_VMS_mode && $Is_VMS_noefs) {
  269         require File::Spec;
  270         foreach my $idx (0..$#ARGV) {
  271             my $path = $ARGV[$idx];
  272             next unless -d $path;
  273 
  274             # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
  275             # chmod 0777, [.foo]bar.dir
  276             my @dirs = File::Spec->splitdir( $path );
  277             $dirs[-1] .= '.dir';
  278             $path = File::Spec->catfile(@dirs);
  279 
  280             $ARGV[$idx] = $path;
  281         }
  282     }
  283 
  284     chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
  285 }
  286 
  287 =item mkpath
  288 
  289     mkpath directory ...
  290 
  291 Creates directories, including any parent directories.
  292 
  293 =cut
  294 
  295 sub mkpath
  296 {
  297  expand_wildcards();
  298  require File::Path;
  299  File::Path::mkpath([@ARGV],0,0777);
  300 }
  301 
  302 =item test_f
  303 
  304     test_f file
  305 
  306 Tests if a file exists.  I<Exits> with 0 if it does, 1 if it does not (ie.
  307 shell's idea of true and false).
  308 
  309 =cut
  310 
  311 sub test_f
  312 {
  313  exit(-f $ARGV[0] ? 0 : 1);
  314 }
  315 
  316 =item test_d
  317 
  318     test_d directory
  319 
  320 Tests if a directory exists.  I<Exits> with 0 if it does, 1 if it does
  321 not (ie. shell's idea of true and false).
  322 
  323 =cut
  324 
  325 sub test_d
  326 {
  327  exit(-d $ARGV[0] ? 0 : 1);
  328 }
  329 
  330 =item dos2unix
  331 
  332     dos2unix files or dirs ...
  333 
  334 Converts DOS and OS/2 linefeeds to Unix style recursively.
  335 
  336 =cut
  337 
  338 sub dos2unix {
  339     require File::Find;
  340     File::Find::find(sub {
  341         return if -d;
  342         return unless -w _;
  343         return unless -r _;
  344         return if -B _;
  345 
  346         local $\;
  347 
  348     my $orig = $_;
  349     my $temp = '.dos2unix_tmp';
  350     open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
  351     open TEMP, ">$temp" or
  352         do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
  353         binmode ORIG; binmode TEMP;
  354         while (my $line = <ORIG>) {
  355             $line =~ s/\015\012/\012/g;
  356             print TEMP $line;
  357         }
  358     close ORIG;
  359     close TEMP;
  360     rename $temp, $orig;
  361 
  362     }, @ARGV);
  363 }
  364 
  365 =back
  366 
  367 =head1 SEE ALSO
  368 
  369 Shell::Command which is these same functions but take arguments normally.
  370 
  371 
  372 =head1 AUTHOR
  373 
  374 Nick Ing-Simmons C<ni-s@cpan.org>
  375 
  376 Maintained by Michael G Schwern C<schwern@pobox.com> within the
  377 ExtUtils-MakeMaker package and, as a separate CPAN package, by
  378 Randy Kobes C<r.kobes@uwinnipeg.ca>.
  379 
  380 =cut
  381