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.7 / Automake / General.pm < prev    next >
Encoding:
Perl POD Document  |  2005-10-16  |  7.3 KB  |  335 lines
  1. # Copyright 2001 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., 59 Temple Place - Suite 330, Boston, MA
  16. # 02111-1307, USA.
  17.  
  18. package Automake::General;
  19.  
  20. use 5.005;
  21. use Exporter;
  22. use File::Basename;
  23. use File::stat;
  24. use IO::File;
  25. use Carp;
  26. use strict;
  27.  
  28. use vars qw (@ISA @EXPORT);
  29.  
  30. @ISA = qw (Exporter);
  31. @EXPORT = qw (&debug &find_configure_ac &find_file &getopt &mktmpdir &mtime
  32.               &uniq &update_file &verbose &xsystem
  33.           $debug $help $me $tmp $verbose $version);
  34.  
  35. # Variable we share with the main package.  Be sure to have a single
  36. # copy of them: using `my' together with multiple inclusion of this
  37. # package would introduce several copies.
  38. use vars qw ($debug);
  39. $debug = 0;
  40.  
  41. use vars qw ($help);
  42. $help = undef;
  43.  
  44. use vars qw ($me);
  45. $me = basename ($0);
  46.  
  47. # Our tmp dir.
  48. use vars qw ($tmp);
  49. $tmp = undef;
  50.  
  51. use vars qw ($verbose);
  52. $verbose = 0;
  53.  
  54. use vars qw ($version);
  55. $version = undef;
  56.  
  57.  
  58. # END
  59. # ---
  60. # Exit nonzero whenever closing STDOUT fails.
  61. # Ideally we should `exit ($? >> 8)', unfortunately, for some reason
  62. # I don't understand, whenever we `exit (1)' somewhere in the code,
  63. # we arrive here with `$? = 29'.  I suspect some low level END routine
  64. # might be responsible.  In this case, be sure to exit 1, not 29.
  65. sub END
  66. {
  67.   my $exit_status = $? ? 1 : 0;
  68.  
  69.   use POSIX qw (_exit);
  70.  
  71.   if (!$debug && defined $tmp && -d $tmp)
  72.     {
  73.       if (<$tmp/*>)
  74.     {
  75.       unlink <$tmp/*>
  76.         or carp ("$me: cannot empty $tmp: $!\n"), _exit (1);
  77.     }
  78.       rmdir $tmp
  79.     or carp ("$me: cannot remove $tmp: $!\n"), _exit (1);
  80.     }
  81.  
  82.   # This is required if the code might send any output to stdout
  83.   # E.g., even --version or --help.  So it's best to do it unconditionally.
  84.   close STDOUT
  85.     or (carp "$me: closing standard output: $!\n"), _exit (1);
  86.  
  87.   _exit ($exit_status);
  88. }
  89.  
  90.  
  91. # debug(@MESSAGE)
  92. # ---------------
  93. # Messages displayed only if $DEBUG and $VERBOSE.
  94. sub debug (@)
  95. {
  96.   print STDERR "$me: ", @_, "\n"
  97.     if $verbose && $debug;
  98. }
  99.  
  100.  
  101. # $CONFIGURE_AC
  102. # &find_configure_ac ()
  103. # ---------------------
  104. sub find_configure_ac ()
  105. {
  106.   if (-f 'configure.ac')
  107.     {
  108.       if (-f 'configure.in')
  109.     {
  110.       carp "warning: `configure.ac' and `configure.in' both present.\n";
  111.       carp "warning: proceeding with `configure.ac'.\n";
  112.     }
  113.       return 'configure.ac';
  114.     }
  115.   elsif (-f 'configure.in')
  116.     {
  117.       return 'configure.in';
  118.     }
  119.   return;
  120. }
  121.  
  122.  
  123. # $FILENAME
  124. # find_file ($FILENAME, @INCLUDE)
  125. # -------------------------------
  126. # We match exactly the behavior of GNU m4: first look in the current
  127. # directory (which includes the case of absolute file names), and, if
  128. # the file is not absolute, just fail.  Otherwise, look in the path.
  129. #
  130. # If the file is flagged as optional (ends with `?'), then return undef
  131. # if absent.
  132. sub find_file ($@)
  133. {
  134.   use File::Spec;
  135.  
  136.   my ($filename, @include) = @_;
  137.   my $optional = 0;
  138.  
  139.   $optional = 1
  140.     if $filename =~ s/\?$//;
  141.  
  142.   return File::Spec->canonpath ($filename)
  143.     if -e $filename;
  144.  
  145.   if (File::Spec->file_name_is_absolute ($filename))
  146.     {
  147.       die "$me: no such file or directory: $filename\n"
  148.     unless $optional;
  149.       return undef;
  150.     }
  151.  
  152.   foreach my $path (reverse @include)
  153.     {
  154.       return File::Spec->canonpath (File::Spec->catfile ($path, $filename))
  155.     if -e File::Spec->catfile ($path, $filename)
  156.     }
  157.  
  158.   die "$me: no such file or directory: $filename\n"
  159.     unless $optional;
  160.  
  161.   return undef;
  162. }
  163.  
  164.  
  165. # getopt (%OPTION)
  166. # ----------------
  167. # Handle the %OPTION, plus all the common options.
  168. # Work around Getopt bugs wrt `-'.
  169. sub getopt (%)
  170. {
  171.   my (%option) = @_;
  172.   use Getopt::Long;
  173.  
  174.   # F*k.  Getopt seems bogus and dies when given `-' with `bundling'.
  175.   # If fixed some day, use this: '' => sub { push @ARGV, "-" }
  176.   my $stdin = grep /^-$/, @ARGV;
  177.   @ARGV = grep !/^-$/, @ARGV;
  178.   %option = (%option,
  179.          "h|help"     => sub { print $help; exit 0 },
  180.              "V|version"  => sub { print $version; exit 0 },
  181.  
  182.              "v|verbose"    => \$verbose,
  183.              "d|debug"      => \$debug,
  184.         );
  185.   Getopt::Long::Configure ("bundling");
  186.   GetOptions (%option)
  187.     or exit 1;
  188.  
  189.     push @ARGV, '-'
  190.     if $stdin;
  191. }
  192.  
  193.  
  194. # mktmpdir ($SIGNATURE)
  195. # ---------------------
  196. # Create a temporary directory which name is based on $SIGNATURE.
  197. sub mktmpdir ($)
  198. {
  199.   my ($signature) = @_;
  200.   my $TMPDIR = $ENV{'TMPDIR'} || '/tmp';
  201.  
  202.   # If mktemp supports dirs, use it.
  203.   $tmp = `(umask 077 &&
  204.            mktemp -d -q "$TMPDIR/${signature}XXXXXX") 2>/dev/null`;
  205.   chomp $tmp;
  206.  
  207.   if (!$tmp || ! -d $tmp)
  208.     {
  209.       $tmp = "$TMPDIR/$signature" . int (rand 10000) . ".$$";
  210.       mkdir $tmp, 0700
  211.     or croak "$me: cannot create $tmp: $!\n";
  212.     }
  213.  
  214.   print STDERR "$me:$$: working in $tmp\n"
  215.     if $debug;
  216. }
  217.  
  218.  
  219. # $MTIME
  220. # MTIME ($FILE)
  221. # -------------
  222. # Return the mtime of $FILE.  Missing files, or `-' standing for STDIN
  223. # or STDOUT are ``obsolete'', i.e., as old as possible.
  224. sub mtime ($)
  225. {
  226.   my ($file) = @_;
  227.  
  228.   return 0
  229.     if $file eq '-' || ! -f $file;
  230.  
  231.   my $stat = stat ($file)
  232.     or croak "$me: cannot stat $file: $!\n";
  233.  
  234.   return $stat->mtime;
  235. }
  236.  
  237.  
  238. # @RES
  239. # uniq (@LIST)
  240. # ------------
  241. # Return LIST with no duplicates.
  242. sub uniq (@)
  243. {
  244.    my @res = ();
  245.    my %seen = ();
  246.    foreach my $item (@_)
  247.      {
  248.        if (! exists $seen{$item})
  249.      {
  250.        $seen{$item} = 1;
  251.        push (@res, $item);
  252.      }
  253.      }
  254.    return wantarray ? @res : "@res";
  255. }
  256.  
  257.  
  258. # &update_file ($FROM, $TO)
  259. # -------------------------
  260. # Rename $FROM as $TO, preserving $TO timestamp if it has not changed.
  261. # Recognize `$TO = -' standing for stdin.
  262. sub update_file ($$)
  263. {
  264.   my ($from, $to) = @_;
  265.   my $SIMPLE_BACKUP_SUFFIX = $ENV{'SIMPLE_BACKUP_SUFFIX'} || '~';
  266.   use File::Compare;
  267.   use File::Copy;
  268.  
  269.   if ($to eq '-')
  270.     {
  271.       my $in = new IO::File ("$from");
  272.       my $out = new IO::File (">-");
  273.       while ($_ = $in->getline)
  274.     {
  275.       print $out $_;
  276.     }
  277.       $in->close;
  278.       unlink ($from)
  279.     or die "$me: cannot not remove $from: $!\n";
  280.       return;
  281.     }
  282.  
  283.   if (-f "$to" && compare ("$from", "$to") == 0)
  284.     {
  285.       # File didn't change, so don't update its mod time.
  286.       print STDERR "$me: `$to' is unchanged\n";
  287.       return
  288.     }
  289.  
  290.   if (-f "$to")
  291.     {
  292.       # Back up and install the new one.
  293.       move ("$to",  "$to$SIMPLE_BACKUP_SUFFIX")
  294.     or die "$me: cannot not backup $to: $!\n";
  295.       move ("$from", "$to")
  296.     or die "$me: cannot not rename $from as $to: $!\n";
  297.       print STDERR "$me: `$to' is updated\n";
  298.     }
  299.   else
  300.     {
  301.       move ("$from", "$to")
  302.     or die "$me: cannot not rename $from as $to: $!\n";
  303.       print STDERR "$me: `$to' is created\n";
  304.     }
  305. }
  306.  
  307.  
  308. # verbose(@MESSAGE)
  309. # -----------------
  310. sub verbose (@)
  311. {
  312.   print STDERR "$me: ", @_, "\n"
  313.     if $verbose;
  314. }
  315.  
  316.  
  317. # xsystem ($COMMAND)
  318. # ------------------
  319. sub xsystem ($)
  320. {
  321.   my ($command) = @_;
  322.  
  323.   verbose "running: $command";
  324.  
  325.   (system $command) == 0
  326.     or croak ("$me: "
  327.           . (split (' ', $command))[0]
  328.           . " failed with exit status: "
  329.           . ($? >> 8)
  330.           . "\n");
  331. }
  332.  
  333.  
  334. 1; # for require
  335.