NetNews Usenet Archive 1993 #3/NN_1993_3.iso/spool/comp/lang/perl/7926

Text File | 1993-01-21 | 20.0 KB | 623 lines

Newsgroups: comp.lang.perl
Path: sparky!uunet!panther!mothost!schbbs!cssmp.corp.mot.com!mmuegel
From: [e-mail] (Michael S. Muegel)
Subject: Tool to determine required libraries
Organization: Corporate Information Office, Schaumburg, Illinois, Motorola, Inc.
Date: Thu, 21 Jan 1993 01:08:55 GMT
Message-ID: <[e-mail]>
Sender: [e-mail] (Net News)
Nntp-Posting-Host: cssmp.corp.mot.com
Lines: 611


I got tired today of always figuring out what libs a program needed when
I wanted to pack something up for someone. So a wrote a little tool to
determine what libraries a program needed. Before you say "hey, that
is impossible" read the manual page. The tool could miss stuff because of
the interpreted nature of Perl; however, it works for all the programs I
threw at it. And it is graceful if it does screw up.

Feedback is encouraged. I hope there was not some easy way to do this
via Perl other than working with %INC within your program. This method
would require you to edit your program.

Regards,
-Mike

---- Cut Here and feed the following to sh ----
#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 01/21/1993 01:07 UTC by [e-mail] (Michael S. Muegel)
# Source directory /home/ustart/NeXT/src/perl-stuff/tools
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   3511 -r--r--r-- prequire.man
#   2257 -r-xr-xr-x prequire
#   3497 -r--r--r-- fileinfo.pl
#   7030 -r--r--r-- newgetopts.pl
#
# ============= prequire.man ==============
if test -f 'prequire.man' -a X"$1" != X"-c"; then
    echo 'x - skipping prequire.man (File already exists)'
else
echo 'x - extracting prequire.man (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'prequire.man' &&
.TH PREQUIRE 1L
\"
\" $Author: mmuegel $
\" $Header: /usr/local/ustart/src/perl-stuff/tools/man/prequire.man,v 1.1 1993/01/21 01:06:36 mmuegel Exp $
\"
.ds mp \fBprequire\fR
.SH NAME
\*(mp - get a list of the required Perl libraries
.SH SYNOPSIS
\*(mp [ \fB-s\fR ] [ \fIfile ...\fR ]
.SH DESCRIPTION
\*(mp will try to determine, recursively as necessary, what Perl libraries
are used by the Perl file(s) specified.  Because of Perl's interpreted nature it
is difficult to determine what files are included; there are so many ways
to do it and many could only be determined at run time. Therefore,
\*(mp looks for the following statements to appear at the beginning of
a line (leading white space allowed):
.sp 1
.RS
.nf
require "file"
require 'file'
do "file"
do 'file'
do file
.fi
.RE
.sp 1
The pathnames that get printed are absolute and show the actual location
of the library in a filesystem. That is, link pathnames are not shown.
Similar to Perl (except more exacting) \*(mp will not parse any
required file more than once.
.sp 1
When an error occurs \*(mp prints a descriptive message and continues.
An error might occur when a Perl library is not in @INC or the parser was
confused. A hereis file that contains leading text matching the
require and do syntax described above can easily cause problems (try
\fBperldb.pl\fR).
.SH OPTIONS
.IP \fB-s\fR
Print the pathnames on the same line separated by a space. The default is
to print one pathname per line.
.IP \fIfile\fR
One or more files to parse. If none are specified standard input is used.
.SH EXAMPLES
In the following example the library pathname compiled into Perl is
\fB/usr/local/ustart/contrib/lib/perl\fR. This is linked to the \fB/home\fR
area. \fBPERLLIB\fR is not set.
.sp 1
.nf
% \fBpwd\fR
/home/ustart/NeXT/src/perl-stuff/tools/test
X
% \fBls\fR
config.pl  input.pl
X
% \fBcat input.pl\fR
# Some test requires
require "newgetopts.pl";
require '../test/config.pl';
X
# Some test dos
do 'ftp.pl';
do dbedit.pl;
X
# Stuff I should ignore
do sub ();
do $sub ();
X
% \fBprequire input.pl\fR
/home/ustart/NeXT/contrib/lib/perl/chat2.pl
/home/ustart/NeXT/contrib/lib/perl/date.pl
/home/ustart/NeXT/contrib/lib/perl/dbedit.pl
/home/ustart/NeXT/contrib/lib/perl/dbfuncs.pl
/home/ustart/NeXT/contrib/lib/perl/dbread.pl
/home/ustart/NeXT/contrib/lib/perl/dbwrite.pl
/home/ustart/NeXT/contrib/lib/perl/ftp.pl
/home/ustart/NeXT/contrib/lib/perl/newgetopts.pl
/home/ustart/NeXT/src/perl-stuff/tools/test/config2.pl
/home/ustart/Sun-4.0/contrib/lib/perl.platform/sys/socket.ph
.fi
.sp 1
In this example \*(mp is used to create a shar file for itself.
.sp 1
.nf
% \fBshar -f man/prequire.man src/prequire `prequire src/prequire` > prequire.shar\fR
shar: saving man/prequire.man (Text)
shar: saving src/prequire (Text)
shar: saving /home/ustart/NeXT/contrib/lib/perl/fileinfo.pl (Text)
shar: saving /home/ustart/NeXT/contrib/lib/perl/newgetopts.pl (Text)
.fi
.SH ENVIRONMENT VARIABLES
.IP \fBPERLLIB\fR 10
This modifies @INC. See \fBperl(1l)\fR.
.SH AUTHOR
.nf
Michael S. Muegel ([e-mail])
UNIX Applications Startup Group
Corporate Information Office, Schaumburg, IL
Motorola, Inc.
.fi
.SH COPYRIGHT NOTICE
Copyright 1993, Motorola, Inc.
.sp 1
Permission to use, copy, modify and distribute without charge this
software, documentation, etc. is granted, provided that this
comment and the author's name is retained.  The author nor Motorola assume any
responsibility for problems resulting from the use of this software.
.SH SEE ALSO
\fBperl(1l)\fR
SHAR_EOF
chmod 0444 prequire.man ||
echo 'restore of prequire.man failed'
Wc_c="`wc -c < 'prequire.man'`"
test 3511 -eq "$Wc_c" ||
    echo 'prequire.man: original size 3511, current size' "$Wc_c"
fi
# ============= prequire ==============
if test -f 'prequire' -a X"$1" != X"-c"; then
    echo 'x - skipping prequire (File already exists)'
else
echo 'x - extracting prequire (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'prequire' &&
#!/usr/local/ustart/bin/perl
X
# NAME
#    prequire - get a list of the required Perl libraries
#
# SYNOPSIS
#    prequire [ -s ] [ file ... ]
#
# AUTHOR
#    Michael S. Muegel <[e-mail]>
#
# RCS INFORMATION
#    $Author: mmuegel $
#    $Source: /usr/local/ustart/src/perl-stuff/tools/src/prequire,v $
#    $Revision: 1.1 $ of $Date: 1993/01/21 00:31:08 $
X
# A better getopts routine
require "newgetopts.pl";
require "fileinfo.pl";
X
# Get the basename of the script
($Script_Name = $0) =~ s/.*\///;
X
# Some famous constants
$USAGE          = "Usage: $Script_Name [ -s ] [ file ... ]\n";
$VERSION        = "${Script_Name} by \$Author: mmuegel $; \$Revision: 1.1 $ of \$Date: 1993/01/21 00:31:08 $";
$SWITCHES       = "s";
X
# Let getopts parse for switches
$Status = &New_Getopts($SWITCHES, $USAGE);
exit (0) if ($Status == -1);
exit (1) if (! $Status);
X
# To figure out what has been required for each program we make an attempt
# to parse for requires.
INPUT: while (<>)
{
X   # Look for various do/require syntaxs described in the manual page
X   next if (! (/^\s*(do|require)\s+['"]([^'"]+)['"]/ || /^\s*(do)\s+([^{\s\$;\(\)]+)/));
X   ($Op, $Lib, $Left) = ($1, $2, $');
X   next if (($Op eq "do") && ($Left =~ /^\s+\(/));
X
X   # Figure out which directory in @INC $Lib came from if the pathname
X   # was relative
X   if ($Lib !~ /^[\/\.]/)
X   {
X      $Found = 0;
X      foreach $Dir (@INC)
X      {
X         if (-f "$Dir/$Lib")
X         {
X            $Found = 1;
X            $Lib = "$Dir/$Lib";
X            last;
X         };
X      };
X
X      # If we did not find it something is afoot
X      if (! $Found)
X      {
X         warn "$Script_Name: $ARGV line $.: \"$Lib\" not found it in \@INC\n";
X     next INPUT;
X      };
X   };
X
X   # OK, now figure out the real pathname of this lib
X   ($Status, $Lib) = &Real_Path ($Lib);
X   if (! $Status)
X   {
X      warn "$Script_Name: $ARGV line $.: $Lib\n" if (! $Status);
X      next INPUT;
X   };
X
X   # Save the library for later use and push it on the input stack so we
X   # look inside of it as well
X   push (@ARGV, $Lib) if (! $Lib_Status {$Lib}++);
};
X
# Now print 'em out
@Libs = sort (keys (%Lib_Status));
if (@Libs)
{
X   $Sep = ($opt_s) ? " " : "\n";
X   print join ($Sep, sort (keys (%Lib_Status))) . "\n";
};
SHAR_EOF
chmod 0555 prequire ||
echo 'restore of prequire failed'
Wc_c="`wc -c < 'prequire'`"
test 2257 -eq "$Wc_c" ||
    echo 'prequire: original size 2257, current size' "$Wc_c"
fi
# ============= fileinfo.pl ==============
if test -f 'fileinfo.pl' -a X"$1" != X"-c"; then
    echo 'x - skipping fileinfo.pl (File already exists)'
else
echo 'x - extracting fileinfo.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'fileinfo.pl' &&
;# NAME
;#    fileinfo.pl - perl function(s) give information on file system objects
;#
;# AUTHOR
;#    Michael S. Muegel ([e-mail])
;#
;# RCS INFORMATION
;#    $Author: mmuegel $
;#    $Header: /usr/local/ustart/src/perl-stuff/libs/fwrdc/misc/RCS/fileinfo.pl,v 1.2 1993/01/20 23:36:51 mmuegel Exp $
;#    $Source: /usr/local/ustart/src/perl-stuff/libs/fwrdc/misc/RCS/fileinfo.pl,v $
X
package fileinfo;
X
# Maximum number of times I can encounter a pathname when figuring out
# real pathname
$MAX_VISITS     = 8;
X
# The print working directory command
$PWD         = "/bin/pwd";
X
;###############################################################################
;# Dir_Name
;#
;# Returns the name of the directory that $Path is in. The name is the
;# logical name. E.g. no link following is done.
;#
;# Written by [e-mail] (Wayne Thompson) and posted to c.l.p.
;# Modified to work with Domain/OS // filesystem.
;#
;# Arguments:
;#    $Path
;#
;# Returns:
;#    $Dir
;###############################################################################
sub main'Dir_Name
{
X    local ($_) = @_;
X    local ($return);
X    s#$#/#;
X    (($return) = m#^(/[/]?)[^/]*/$#) ||
X        (($return) = m#(.*[^/])/+[^/]+/+$#) ||
X        ($return = '.');
X    $return;
};
X
X
;###############################################################################
;# Real_Path
;#
;# Determines the actual physical path of $Path. It will follow links if
;# necessary. When sitting in my $HOME and given "bin" will return
;# //fwase12/users/mmuegel/bin. Returns with $Status 1 if it was able to
;# compute the real path; 0 otherwise. If 0 an error string is returned
;# instead of the pathname. Catches recursive links by setting a limit on the
;# number of times a pathname can be encountered. The maximum number is
;# $MAX_VISITS.
;#
;# Arguments:
;#    $Path
;#
;# Returns:
;#    $Status, $Real_Path
;###############################################################################
sub main'Real_Path
{
X   local ($Logical_Path) = @_;
X   local (%Traversed_Count, $Start_Dir, $Status, $Real_Path);
X
X   sub Real_Path_Rec
X   {
X      local ($Path) = @_;
X      local ($Basename, $Dir, $New_Path, $Real_Path, $Error);
X
X      # Check for recursion
X      return (0, "$Logical_Path: possible recursion for object $Path")
X         if ($Traversed_Count {$Path}++ == $MAX_VISITS);
X
X      # Get the basename and directory $Path is in
X      ($Basename = $Path) =~ s/.*\///;
X      $Dir = &main'Dir_Name ($Path);
X
X      # Collapse //node/.. -> // because of bug in Domain/OS
X      $Dir =~ s#^//[^/]+/\.\.#//#;
X
X      # Change to the directory $Path is in
X      chdir ($Dir) || return (0, "$Logical_Path: could not chdir to $Dir: $!") if ($Dir ne ".");
X      chop ($Dir = `$PWD 2>/dev/null`) || return (0, "$Logical_Path: can not get current working directory");
X
X      if (-l $Basename)
X      {
X         $New_Path = readlink ($Basename) || return (0, "$Logical_Path: can not read link $Path/$Basename");
X         return (&Real_Path_Rec ($New_Path));
X      };
X
X      chop ($Dir) if ($Dir =~ /^(\/){1,2}$/);
X      return (1, "$Dir/$Basename");
X   };
X
X   # Save the cwd, figure out real path, and change back to cwd
X   chop ($Start_Dir = `$PWD 2>/dev/null`) || return (0, "$Logical_Path: can not get current working directory");
X   ($Status, $Real_Path) = &Real_Path_Rec ($Logical_Path);
X   chdir ($Start_Dir) || return (0, "$Logical_Path: could not chdir to $Start_Dir: $!");
X   return ($Status, $Real_Path);
X
};
X
1;
SHAR_EOF
chmod 0444 fileinfo.pl ||
echo 'restore of fileinfo.pl failed'
Wc_c="`wc -c < 'fileinfo.pl'`"
test 3497 -eq "$Wc_c" ||
    echo 'fileinfo.pl: original size 3497, current size' "$Wc_c"
fi
# ============= newgetopts.pl ==============
if test -f 'newgetopts.pl' -a X"$1" != X"-c"; then
    echo 'x - skipping newgetopts.pl (File already exists)'
else
echo 'x - extracting newgetopts.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'newgetopts.pl' &&
;# NAME
;#    newgetopts.pl - a better newgetopt (which is a better getopts which is
;#                    a better getopt ;-)
;#
;# AUTHOR
;#    Mike Muegel ([e-mail])
;#
;# $Author: mmuegel $
;# $Header: //fwans00/usr/local/lib/perl/RCS/newgetopts.pl,v 1.6 91/09/05 16:29:39 mmuegel Exp $
X
;###############################################################################
;# New_Getopts
;#
;# Does not care about order of switches, options, and arguments like
;# getopts.pl. Thus all non-switches/options will be kept in ARGV even if they
;# are not at the end. If $Pass_Invalid is set all unkown options will be
;# passed back to the caller by keeping them in @ARGV. This is useful when
;# parsing a command line for your script while ignoring options that you
;# may pass to another script. If this is set New_Getopts tries to maintain
;# the switch clustering on the unkown switches.
;#
;# Accepts the special argument -usage to print the Usage string. Also accepts
;# the special option -version which prints the contents of the string
;# $VERSION. $VERSION may or may not have an embeded \n in it. If -usage
;# or -version are specified a status of -1 is returned. Note that the usage
;# option is only accepted if the usage string is not null.
;#
;# $Switches is just like the formal arguemnt of getopts.pl. $Usage is a usage
;# string with or without a trailing \n. *Switch_To_Order is an optional
;# pointer to the name of an associative array which will contain a mapping of
;# switch names to the order in which (if at all) the argument was entered.
;#
;# For example, if @ARGV contains -v, -x, test:
;#
;#    $Switch_To_Order {"v"} = 1;
;#    $Switch_To_Order {"x"} = 2;
;#
;# Note that in the case of multiple occurances of an option $Switch_To_Order
;# will store each occurance of the argument via a string that emulates
;# an array. This is done by using join ($;, ...). You can retrieve the
;# array by using split (/$;/, ...).
;#
;# *Split_ARGV is an optional pointer to an array which will conatin the
;# original switches along with their values. For the example used above
;# Split_ARGV would contain:
;#
;#   @Split_ARGV = ("v", "", "x", "test");
;#
;# Another exciting ;-) feature that newgetopts has. Along with creating the
;# normal $opt_ scalars for the last value of an argument the list @opt_ is
;# created. It is an array which contains all the values of arguments to the
;# basename of the variable. They are stored in the order which they occured
;# on the command line starting with $[. Note that blank arguments are stored
;# as "". Along with providing support for multiple options on the command
;# line this also provides a method of counting the number of times an option
;# was specified via $#opt_.
;#
;# Automatically resets all $opt_, @opt_, %Switch_To_Order, and @Split_ARGV
;# variables so that New_Getopts may be called more than once from within
;# the same program. Thus, if $opt_v is set upon entry to New_Getopts and
;# -v is not in @ARGV $opt_v will not be set upon exit.
;#
;# Arguments:
;#    $Switches, $Usage, $Pass_Invalid, *Switch_To_Order, *Split_ARGV
;#
;# Returns:
;#    -1, 0, or 1 depending on status (printed Usage/Version, OK, not OK)
;###############################################################################
sub New_Getopts
{
X    local($taint_argumentative, $Usage, $Pass_Invalid, *Switch_To_Order,
X          *Split_ARGV) = @_;
X    local(@args,$_,$first,$rest,$errs, @leftovers, @current_leftovers,
X          %Switch_Found);
X    local($[, $*, $Script_Name, $argumentative);
X
X    # Untaint the argument cluster so that we can use this with taintperl
X    $taint_argumentative =~ /^(.*)$/;
X    $argumentative = $1;
X
X    # Clear anything that might still be set from a previous New_Getopts
X    # call.
X    @Split_ARGV = ();
X
X    # Get the basename of the calling script
X    ($Script_Name = $0) =~ s/.*\///;
X
X    # Make Usage have a trailing \n
X    $Usage .= "\n" if ($Usage !~ /\n$/);
X
X    @args = split( / */, $argumentative );
X
X    # Clear anything that might still be set from a previous New_Getopts call.
X    foreach $first (@args)
X    {
X       next if ($first eq ":");
X       delete $Switch_Found {$first};
X       delete $Switch_To_Order {$first};
X       eval "undef \@opt_$first; undef \$opt_$first;";
X    };
X
X    while (@ARGV)
X    {
X        # Let usage through
X        if (($ARGV[0] eq "-usage") && ($Usage ne "\n"))
X        {
X           print $Usage;
X           exit (-1);
X        }
X
X        elsif ($ARGV[0] eq "-version")
X        {
X           if ($VERSION)
X           {
X              print $VERSION;
X              print "\n" if ($VERSION !~ /\n$/);
X           }
X           else
X           {
X              warn "${Script_Name}: no version information available, sorry\n";
X           }
X           exit (-1);
X        }
X
X        elsif (($_ = $ARGV[0]) =~ /^-(.)(.*)/)
X        {
X           ($first,$rest) = ($1,$2);
X           $pos = index($argumentative,$first);
X
X           $Switch_To_Order {$first} = join ($;, split (/$;/, $Switch_To_Order {$first}), ++$Order);
X
X           if($pos >= $[)
X           {
X               if($args[$pos+1] eq ':')
X               {
X                   shift(@ARGV);
X                   if($rest eq '')
X                   {
X                       $rest = shift(@ARGV);
X                   }
X
X                   eval "\$opt_$first = \$rest;";
X                   eval "push (\@opt_$first, \$rest);";
X                   push (@Split_ARGV, $first, $rest);
X               }
X               else
X               {
X                   eval "\$opt_$first = 1";
X                   eval "push (\@opt_$first, '');";
X                   push (@Split_ARGV, $first, "");
X
X                   if($rest eq '')
X                   {
X                       shift(@ARGV);
X                   }
X                   else
X                   {
X                       $ARGV[0] = "-$rest";
X                   }
X               }
X           }
X
X           else
X           {
X               # Save any other switches if $Pass_Valid
X               if ($Pass_Invalid)
X               {
X                  push (@current_leftovers, $first);
X               }
X               else
X               {
X                  warn "${Script_Name}: unknown option: $first\n";
X                  ++$errs;
X               };
X               if($rest ne '')
X               {
X                   $ARGV[0] = "-$rest";
X               }
X               else
X               {
X                   shift(@ARGV);
X               }
X           }
X        }
X
X        else
X        {
X           push (@leftovers, shift (@ARGV));
X        };
X
X        # Save any other switches if $Pass_Valid
X        if ((@current_leftovers) && ($rest eq ''))
X        {
X           push (@leftovers, "-" . join ("", @current_leftovers));
X           @current_leftovers = ();
X        };
X    };
X
X    # Automatically print Usage if a warning was given
X    @ARGV = @leftovers;
X    if ($errs != 0)
X    {
X       warn $Usage;
X       return (0);
X    }
X    else
X    {
X       return (1);
X    }
X
}
X
1;
SHAR_EOF
chmod 0444 newgetopts.pl ||
echo 'restore of newgetopts.pl failed'
Wc_c="`wc -c < 'newgetopts.pl'`"
test 7030 -eq "$Wc_c" ||
    echo 'newgetopts.pl: original size 7030, current size' "$Wc_c"
fi
exit 0

--
+----------------------------------------------------------------------------+
| Michael S. Muegel                  | Internet E-Mail:    [e-mail]   |
| UNIX Applications Startup Group    | Moto Dist E-Mail:   X10090            |
| Corporate Information Office       | Voice:              [phone]    |
| Motorola                           | ... these are my opinions, honest ... |
+----------------------------------------------------------------------------+