home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / share / automake-1.9 / Automake / FileUtils.pm < prev    next >
Encoding:
Perl POD Document  |  2005-10-13  |  8.4 KB  |  386 lines
  1. # Copyright (C) 2003, 2004, 2005  Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2, or (at your option)
  6. # any later version.
  7.  
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12.  
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16. # 02110-1301, USA.
  17.  
  18. package Automake::FileUtils;
  19.  
  20. =head1 NAME
  21.  
  22. Automake::FileUtils - handling files
  23.  
  24. =head1 SYNOPSIS
  25.  
  26.   use Automake::FileUtils
  27.  
  28. =head1 DESCRIPTION
  29.  
  30. This perl module provides various general purpose file handling functions.
  31.  
  32. =cut
  33.  
  34. use strict;
  35. use Exporter;
  36. use File::stat;
  37. use IO::File;
  38. use Automake::Channels;
  39. use Automake::ChannelDefs;
  40.  
  41. use vars qw (@ISA @EXPORT);
  42.  
  43. @ISA = qw (Exporter);
  44. @EXPORT = qw (&contents
  45.           &find_file &mtime
  46.           &update_file &up_to_date_p
  47.           &xsystem &xqx &dir_has_case_matching_file &reset_dir_cache);
  48.  
  49.  
  50. =item C<find_file ($file_name, @include)>
  51.  
  52. Return the first path for a C<$file_name> in the C<include>s.
  53.  
  54. We match exactly the behavior of GNU M4: first look in the current
  55. directory (which includes the case of absolute file names), and, if
  56. the file is not absolute, just fail.  Otherwise, look in C<@include>.
  57.  
  58. If the file is flagged as optional (ends with C<?>), then return undef
  59. if absent, otherwise exit with error.
  60.  
  61. =cut
  62.  
  63. # $FILE_NAME
  64. # find_file ($FILE_NAME, @INCLUDE)
  65. # -------------------------------
  66. sub find_file ($@)
  67. {
  68.   use File::Spec;
  69.  
  70.   my ($file_name, @include) = @_;
  71.   my $optional = 0;
  72.  
  73.   $optional = 1
  74.     if $file_name =~ s/\?$//;
  75.  
  76.   return File::Spec->canonpath ($file_name)
  77.     if -e $file_name;
  78.  
  79.   if (File::Spec->file_name_is_absolute ($file_name))
  80.     {
  81.       fatal "$file_name: no such file or directory"
  82.     unless $optional;
  83.       return undef;
  84.     }
  85.  
  86.   foreach my $path (@include)
  87.     {
  88.       return File::Spec->canonpath (File::Spec->catfile ($path, $file_name))
  89.     if -e File::Spec->catfile ($path, $file_name)
  90.     }
  91.  
  92.   fatal "$file_name: no such file or directory"
  93.     unless $optional;
  94.  
  95.   return undef;
  96. }
  97.  
  98. =item C<mtime ($file)>
  99.  
  100. Return the mtime of C<$file>.  Missing files, or C<-> standing for
  101. C<STDIN> or C<STDOUT> are ``obsolete'', i.e., as old as possible.
  102.  
  103. =cut
  104.  
  105. # $MTIME
  106. # MTIME ($FILE)
  107. # -------------
  108. sub mtime ($)
  109. {
  110.   my ($file) = @_;
  111.  
  112.   return 0
  113.     if $file eq '-' || ! -f $file;
  114.  
  115.   my $stat = stat ($file)
  116.     or fatal "cannot stat $file: $!";
  117.  
  118.   return $stat->mtime;
  119. }
  120.  
  121.  
  122. =item C<update_file ($from, $to, [$force])>
  123.  
  124. Rename C<$from> as C<$to>, preserving C<$to> timestamp if it has not
  125. changed, unless C<$force> is true (defaults to false).  Recognize
  126. C<$to> = C<-> standing for C<STDIN>.  C<$from> is always
  127. removed/renamed.
  128.  
  129. =cut
  130.  
  131. # &update_file ($FROM, $TO; $FORCE)
  132. # ---------------------------------
  133. sub update_file ($$;$)
  134. {
  135.   my ($from, $to, $force) = @_;
  136.   $force = 0
  137.     unless defined $force;
  138.   my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~';
  139.   use File::Compare;
  140.   use File::Copy;
  141.  
  142.   if ($to eq '-')
  143.     {
  144.       my $in = new IO::File ("$from");
  145.       my $out = new IO::File (">-");
  146.       while ($_ = $in->getline)
  147.     {
  148.       print $out $_;
  149.     }
  150.       $in->close;
  151.       unlink ($from) || fatal "cannot remove $from: $!";
  152.       return;
  153.     }
  154.  
  155.   if (!$force && -f "$to" && compare ("$from", "$to") == 0)
  156.     {
  157.       # File didn't change, so don't update its mod time.
  158.       msg 'note', "`$to' is unchanged";
  159.       unlink ($from)
  160.         or fatal "cannot remove $from: $!";
  161.       return
  162.     }
  163.  
  164.   if (-f "$to")
  165.     {
  166.       # Back up and install the new one.
  167.       move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
  168.     or fatal "cannot backup $to: $!";
  169.       move ("$from", "$to")
  170.     or fatal "cannot rename $from as $to: $!";
  171.       msg 'note', "`$to' is updated";
  172.     }
  173.   else
  174.     {
  175.       move ("$from", "$to")
  176.     or fatal "cannot rename $from as $to: $!";
  177.       msg 'note', "`$to' is created";
  178.     }
  179. }
  180.  
  181.  
  182. =item C<up_to_date_p ($file, @dep)>
  183.  
  184. Is C<$file> more recent than C<@dep>?
  185.  
  186. =cut
  187.  
  188. # $BOOLEAN
  189. # &up_to_date_p ($FILE, @DEP)
  190. # ---------------------------
  191. sub up_to_date_p ($@)
  192. {
  193.   my ($file, @dep) = @_;
  194.   my $mtime = mtime ($file);
  195.  
  196.   foreach my $dep (@dep)
  197.     {
  198.       if ($mtime < mtime ($dep))
  199.     {
  200.       verb "up_to_date ($file): outdated: $dep";
  201.       return 0;
  202.     }
  203.     }
  204.  
  205.   verb "up_to_date ($file): up to date";
  206.   return 1;
  207. }
  208.  
  209.  
  210. =item C<handle_exec_errors ($command)>
  211.  
  212. Display an error message for C<$command>, based on the content of
  213. C<$?> and C<$!>.
  214.  
  215. =cut
  216.  
  217. # handle_exec_errors ($COMMAND)
  218. # -----------------------------
  219. sub handle_exec_errors ($)
  220. {
  221.   my ($command) = @_;
  222.  
  223.   $command = (split (' ', $command))[0];
  224.   if ($!)
  225.     {
  226.       fatal "failed to run $command: $!";
  227.     }
  228.   else
  229.     {
  230.       use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
  231.  
  232.       if (WIFEXITED ($?))
  233.     {
  234.       my $status = WEXITSTATUS ($?);
  235.       # Propagate exit codes.
  236.       fatal ('',
  237.          "$command failed with exit status: $status",
  238.          exit_code => $status);
  239.     }
  240.       elsif (WIFSIGNALED ($?))
  241.     {
  242.       my $signal = WTERMSIG ($?);
  243.       fatal "$command terminated by signal: $signal";
  244.     }
  245.       else
  246.     {
  247.       fatal "$command exited abnormally";
  248.     }
  249.     }
  250. }
  251.  
  252. =item C<xqx ($command)>
  253.  
  254. Same as C<qx> (but in scalar context), but fails on errors.
  255.  
  256. =cut
  257.  
  258. # xqx ($COMMAND)
  259. # --------------
  260. sub xqx ($)
  261. {
  262.   my ($command) = @_;
  263.  
  264.   verb "running: $command";
  265.  
  266.   $! = 0;
  267.   my $res = `$command`;
  268.   handle_exec_errors $command
  269.     if $?;
  270.  
  271.   return $res;
  272. }
  273.  
  274.  
  275. =item C<xsystem ($command)>
  276.  
  277. Same as C<system>, but fails on errors, and reports the C<$command>
  278. in verbose mode.
  279.  
  280. =cut
  281.  
  282. # xsystem ($COMMAND)
  283. # ------------------
  284. sub xsystem ($)
  285. {
  286.   my ($command) = @_;
  287.  
  288.   verb "running: $command";
  289.  
  290.   $! = 0;
  291.   handle_exec_errors $command
  292.     if system $command;
  293. }
  294.  
  295.  
  296. =item C<contents ($file_name)>
  297.  
  298. Return the contents of C<$file_name>.
  299.  
  300. =cut
  301.  
  302. # contents ($FILE_NAME)
  303. # ---------------------
  304. sub contents ($)
  305. {
  306.   my ($file) = @_;
  307.   verb "reading $file";
  308.   local $/;            # Turn on slurp-mode.
  309.   my $f = new Automake::XFile "< $file";
  310.   my $contents = $f->getline;
  311.   $f->close;
  312.   return $contents;
  313. }
  314.  
  315.  
  316. =item C<dir_has_case_matching_file ($DIRNAME, $FILE_NAME)>
  317.  
  318. Return true iff $DIR contains a file name that matches $FILE_NAME case
  319. insensitively.
  320.  
  321. We need to be cautious on case-insensitive case-preserving file
  322. systems (e.g. Mac OS X's HFS+).  On such systems C<-f 'Foo'> and C<-f
  323. 'foO'> answer the same thing.  Hence if a package distributes its own
  324. F<CHANGELOG> file, but has no F<ChangeLog> file, automake would still
  325. try to distribute F<ChangeLog> (because it thinks it exists) in
  326. addition to F<CHANGELOG>, although it is impossible for these two
  327. files to be in the same directory (the two file names designate the
  328. same file).
  329.  
  330. =cut
  331.  
  332. use vars '%_directory_cache';
  333. sub dir_has_case_matching_file ($$)
  334. {
  335.   # Note that print File::Spec->case_tolerant returns 0 even on MacOS
  336.   # X (with Perl v5.8.1-RC3 at least), so do not try to shortcut this
  337.   # function using that.
  338.  
  339.   my ($dirname, $file_name) = @_;
  340.   return 0 unless -f "$dirname/$file_name";
  341.  
  342.   # The file appears to exist, however it might be a mirage if the
  343.   # system is case insensitive.  Let's browse the directory and check
  344.   # whether the file is really in.  We maintain a cache of directories
  345.   # so Automake doesn't spend all its time reading the same directory
  346.   # again and again.
  347.   if (!exists $_directory_cache{$dirname})
  348.     {
  349.       error "failed to open directory `$dirname'"
  350.     unless opendir (DIR, $dirname);
  351.       $_directory_cache{$dirname} = { map { $_ => 1 } readdir (DIR) };
  352.       closedir (DIR);
  353.     }
  354.   return exists $_directory_cache{$dirname}{$file_name};
  355. }
  356.  
  357. =item C<reset_dir_cache ($dirname)>
  358.  
  359. Clear C<dir_has_case_matching_file>'s cache for C<$dirname>.
  360.  
  361. =cut
  362.  
  363. sub reset_dir_cache ($)
  364. {
  365.   delete $_directory_cache{$_[0]};
  366. }
  367.  
  368. 1; # for require
  369.  
  370. ### Setup "GNU" style for perl-mode and cperl-mode.
  371. ## Local Variables:
  372. ## perl-indent-level: 2
  373. ## perl-continued-statement-offset: 2
  374. ## perl-continued-brace-offset: 0
  375. ## perl-brace-offset: 0
  376. ## perl-brace-imaginary-offset: 0
  377. ## perl-label-offset: -2
  378. ## cperl-indent-level: 2
  379. ## cperl-brace-offset: 0
  380. ## cperl-continued-brace-offset: 0
  381. ## cperl-label-offset: -2
  382. ## cperl-extra-newline-before-brace: t
  383. ## cperl-merge-trailing-else: nil
  384. ## cperl-continued-statement-offset: 2
  385. ## End:
  386.