Public Pastes
daily pastebin goal
65%
SHARE
TWEET

root

a guest Jul 1st, 2008 83 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #!/usr/bin/perl
  2. #===================================================================================
  3. #
  4. #         FILE:  pmdesc3
  5. #
  6. #     SYNOPSIS:  Find versions and descriptions of installed perl Modules and PODs
  7. #
  8. #  DESCRIPTION:  See POD below.
  9. #
  10. #      CREATED:  15.06.2004 22:12:41 CEST
  11. #     REVISION:  $Id: pmdesc3.pl,v 1.4 2007/08/10 16:02:32 mehner Exp $
  12. #         TODO:  Replace UNIX sort pipe.
  13. #                
  14. #===================================================================================
  15.  
  16. package pmdesc3;
  17.  
  18. require 5.6.1;
  19.  
  20. use strict;
  21. use warnings;
  22. use Carp;
  23. use ExtUtils::MakeMaker;
  24. use File::Find           qw(find);
  25. use Getopt::Std          qw(getopts);
  26. #use version;
  27. our $VERSION        = qw(1.2.3);  # update POD at the end of this file
  28.  
  29. my  $MaxDescLength  = 150;        # Maximum length for the description field:
  30.                                   # prevents slurping in big amount of faulty docs.
  31.  
  32. my  $rgx_version  = q/\Av?\d+(\.\w+)*\Z/; # regex for module versions
  33.  
  34. #===  FUNCTION  ====================================================================
  35. #         NAME:  usage
  36. #===================================================================================
  37. sub usage {
  38.   my  $searchdirs = " "x12;
  39.   $searchdirs .= join( "\n"." "x12, sort { length $b <=> length $a } @INC ) . "\n";
  40.   print <<EOT;
  41. Usage:   pmdesc3.pl [-h] [-s] [-t ddd] [-v dd] [--] [dir [dir [dir [...]]]]
  42. Options:  -h         print this message
  43.           -s         sort output (not under Windows)
  44.           -t ddd     name column has width ddd (1-3 digits); default 36
  45.           -v  dd     version column has width ddd (1-3 digits); default 10
  46.           If no directories given, searches:
  47. $searchdirs
  48. EOT
  49.   exit;
  50. }
  51.  
  52. #===  FUNCTION  ====================================================================
  53. #         NAME:  get_module_name
  54. #===================================================================================
  55. sub get_module_name {
  56.   my ($path, $relative_to) = @_;
  57.  
  58.   local $_ = $path;
  59.   s!\A\Q$relative_to\E/?!!;
  60.   s! \.p(?:m|od) \z!!x;
  61.   s!/!::!g;
  62.  
  63.   return $_;
  64. }
  65.  
  66. #===  FUNCTION  ====================================================================
  67. #         NAME:  get_module_description
  68. #===================================================================================
  69. sub get_module_description
  70. {
  71.   my  $desc;
  72.   my  ($INFILE_file_name) = @_;                 # input file name
  73.  
  74.   undef $/;                                     # undefine input record separator
  75.  
  76.   open  my $INFILE, '<', $INFILE_file_name
  77.       or die  "$0 : failed to open  input file '$INFILE_file_name' : $!\n";
  78.  
  79.   my  $file = <$INFILE>;                        # slurp mode
  80.  
  81.   close  $INFILE
  82.       or warn "$0 : failed to close input file '$INFILE_file_name' : $!\n";
  83.  
  84.   $file =~  s/\cM\cJ/\cJ/g;                     # remove DOS line ends
  85.   $file =~  m/\A=head1\s+NAME(.*?)\n=\w+/s;     # file starts with '=head1' (PODs)
  86.   $desc = $1;
  87.  
  88.   if ( ! defined $desc  )
  89.   {
  90.     $file =~  m/\n=head1\s+NAME(.*?)\n=\w+/s;   # '=head1' is embedded
  91.     $desc = $1;
  92.   }
  93.  
  94.   if ( ! defined $desc  )
  95.   {
  96.     $file =~  m/\n=head1\s+DESCRIPTION(.*?)\n=\w+/s; # '=head1' is embedded
  97.     $desc = $1;
  98.   }
  99.  
  100.   if ( defined $desc )
  101.   {
  102.     $desc =~ s/B<([^>]+)>/$1/gs;                # remove bold markup
  103.     $desc =~ s/C<([^>]+)>/'$1'/gs;              # single quotes to indicate literal
  104.     $desc =~ s/E<lt>/</gs;                      # replace markup for <
  105.     $desc =~ s/E<gt>/>/gs;                      # replace markup for >
  106.     $desc =~ s/F<([^>]+)>/$1/gs;                # remove filename markup
  107.     $desc =~ s/I<([^>]+)>/$1/gs;                # remove italic markup
  108.     $desc =~ s/L<([^>]+)>/$1/gs;                # remove link markup
  109.     $desc =~ s/X<([^>]+)>//gs;                  # remove index markup
  110.     $desc =~ s/Z<>//gs;                         # remove zero-width character
  111.     $desc =~ s/S<([^>]+)>/$1/gs;                # remove markup for nonbreaking spaces
  112.  
  113.     $desc =~ s/\A[ \t\n]*//s;                   # remove leading whitespaces
  114.     $desc =~ s/\n\s+\n/\n\n/sg;                 # make true empty lines
  115.     $desc =~ s/\n\n.*$//s;                      # discard all trailing paragraphs
  116.     $desc =~ s/\A.*?\s+-+\s+//s;                # discard leading module name
  117.     $desc =~ s/\n/ /sg;                         # join lines
  118.     $desc =~ s/\s+/ /g;                         # squeeze whitespaces
  119.     $desc =~ s/\s*$//g;                         # remove trailing whitespaces
  120.     $desc =  substr $desc, 0, $MaxDescLength;   # limited length
  121.   }
  122.   return $desc;
  123. }
  124.  
  125. #===  FUNCTION  ====================================================================
  126. #         NAME:  get_module_version
  127. #===================================================================================
  128. sub get_module_version {
  129.   local $_;                                     # MM->parse_version is naughty
  130.   my $vers_code = MM->parse_version($File::Find::name) || '';
  131.   $vers_code = undef unless $vers_code =~ /$rgx_version/;
  132.   return $vers_code;
  133. }
  134.  
  135. #===  FUNCTION  ====================================================================
  136. #         NAME:  MAIN
  137. #===================================================================================
  138.  
  139. my %visited;
  140.  
  141. $|++;
  142.  
  143. #---------------------------------------------------------------------------
  144. #  process options and command line arguments
  145. #---------------------------------------------------------------------------
  146. my  %options;
  147.  
  148. getopts("hst:v:", \%options)         or $options{h}=1;
  149.  
  150. my  @args = @ARGV;
  151. @ARGV = @INC unless @ARGV;
  152.  
  153. usage() if $options{h};                               #  option -h  :  usage
  154.  
  155. #---------------------------------------------------------------------------
  156. #  option -t : width of the module name column
  157. #---------------------------------------------------------------------------
  158. usage() if $options{t} && $options{t}!~/^\d{1,3}$/;   # width 1-3 digits
  159.  
  160. $options{t} = "36" unless $options{t};
  161.  
  162. #---------------------------------------------------------------------------
  163. #  option -v : width of the version column
  164. #---------------------------------------------------------------------------
  165. usage() if $options{v} && $options{v}!~/^\d{1,2}$/;   # width 1-2 digits
  166.  
  167. $options{v} = "10" unless $options{v};
  168.  
  169. #---------------------------------------------------------------------------
  170. #  option -s  :  install an output filter to sort the module list
  171. #---------------------------------------------------------------------------
  172. if ($options{s}) {
  173.     usage() if $^O eq "MSWin32";
  174.     if ( open(ME, "-|") ) {
  175.         $/ = "";
  176.         while ( <ME> ) {
  177.             chomp;
  178.             print join("\n", sort split /\n/), "\n";
  179.         }
  180.         exit;
  181.     }
  182. }
  183.  
  184. #---------------------------------------------------------------------------
  185. #  process
  186. #---------------------------------------------------------------------------
  187. #
  188. # :WARNING:15.04.2005:Mn: under Windows descending into subdirs will be
  189. # suppressed by the the preprocessing part of the following call to find
  190. # :TODO:16.04.2005:Mn: remove code doubling
  191. #
  192. if ( $^O ne "MSWin32" ) {                       # ----- UNIX, Linux, ...
  193.  
  194.     for my $inc_dir (sort { length $b <=> length $a } @ARGV) {
  195.         find({
  196.                 wanted => sub {
  197.                     return unless /\.p(?:m|od)\z/ && -f;
  198.  
  199.                     #---------------------------------------------------------------------
  200.                     #  return from function if there exists a pod-file for this module
  201.                     #---------------------------------------------------------------------
  202.                     my $pod = $_;
  203.                     my $pm  = $_;
  204.                     if ( m/\.pm\z/ )
  205.                     {
  206.                         $pod  =~ s/\.pm\z/\.pod/;
  207.                         return if -f $pod;
  208.                     }
  209.  
  210.                     my $module  = get_module_name($File::Find::name, $inc_dir);
  211.                     my $version;
  212.                     if ( /\.pod\z/ )
  213.                     {
  214.                         $pm =~ s/\.pod\z/\.pm/;
  215.                         #-------------------------------------------------------------------
  216.                         #  try to find the version from the pm-file
  217.                         #-------------------------------------------------------------------
  218.                         if ( -f $pm )
  219.                         {
  220.                             local $_;
  221.                             $version = MM->parse_version($pm) || "";
  222.                             $version = undef unless $version =~ /$rgx_version/;
  223.                         }
  224.                     }
  225.                     else
  226.                     {
  227.                         $version = get_module_version($_);
  228.                     }
  229.                     my $desc = get_module_description($_);
  230.  
  231.                     $version = defined $version ? " ($version)" : " (n/a)";
  232.                     $desc    = defined $desc    ? " $desc"      : " <description not available>";
  233.  
  234.                     printf("%-${options{t}}s%-${options{v}}s%-s\n", $module, $version, $desc );
  235.  
  236.                 },
  237.  
  238.                 preprocess => sub {
  239.                     my ($dev, $inode) = stat $File::Find::dir or return;
  240.                     $visited{"$dev:$inode"}++ ? () : @_;
  241.                 },
  242.             },
  243.             $inc_dir);
  244.     }
  245. }
  246. else {                                          # ----- MS Windows
  247.     for my $inc_dir (sort { length $b <=> length $a } @ARGV) {
  248.         find({
  249.                 wanted => sub {
  250.                     return unless /\.p(?:m|od)\z/ && -f;
  251.  
  252.                     #---------------------------------------------------------------------
  253.                     #  return from function if there exists a pod-file for this module
  254.                     #---------------------------------------------------------------------
  255.                     my $pod = $_;
  256.                     my $pm  = $_;
  257.                     if ( m/\.pm\z/ )
  258.                     {
  259.                         $pod  =~ s/\.pm\z/\.pod/;
  260.                         return if -f $pod;
  261.                     }
  262.  
  263.                     my $module  = get_module_name($File::Find::name, $inc_dir);
  264.                     my $version;
  265.                     if ( /\.pod\z/ )
  266.                     {
  267.                         $pm =~ s/\.pod\z/\.pm/;
  268.                         #-------------------------------------------------------------------
  269.                         #  try to find the version from the pm-file
  270.                         #-------------------------------------------------------------------
  271.                         if ( -f $pm )
  272.                         {
  273.                             local $_;
  274.                             $version = MM->parse_version($pm) || "";
  275.                             $version = undef unless $version =~ /$rgx_version/;
  276.                         }
  277.                     }
  278.                     else
  279.                     {
  280.                         $version = get_module_version($_);
  281.                     }
  282.                     my $desc = get_module_description($_);
  283.  
  284.                     $version = defined $version ? " ($version)" : " (n/a)";
  285.                     $desc    = defined $desc    ? " $desc"      : " <description not available>";
  286.  
  287.                     printf("%-${options{t}}s%-${options{v}}s%-s\n", $module, $version, $desc );
  288.  
  289.                 },
  290.             },
  291.             $inc_dir);
  292.     }
  293. }
  294.  
  295. #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  296. #  Modul Documentation
  297. #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  298.  
  299. =head1 NAME
  300.  
  301. pmdesc3 - List name, version, and description of all installed perl modules and PODs
  302.  
  303. =head1 SYNOPSIS
  304.  
  305.     pmdesc3.pl
  306.  
  307.     pmdesc3.pl ~/perllib
  308.  
  309. =head1 DESCRIPTION
  310.  
  311.   pmdesc3.pl [-h] [-s] [-t ddd] [-v dd] [--] [dir [dir [dir [...]]]]
  312.  
  313.   OPTIONS:  -h     : print help message; show search path
  314.             -s     : sort output (not under Windows)
  315.             -t ddd : name column has width ddd (1-3 digits); default 36
  316.             -v  dd : version column has width dd (1-2 digits); default 10
  317.  
  318. Find name, version and description of all installed Perl modules and PODs.
  319. If no directories given, searches @INC .
  320. The first column of the output (see below) can be used as module name or
  321. FAQ-name for perldoc.
  322.  
  323. Some modules are split into a pm-file and an accompanying pod-file.
  324. The version number is always taken from the pm-file.
  325.  
  326. The description found will be cut down to a length of at most
  327. 150 characters (prevents slurping in big amount of faulty docs).
  328.  
  329.  
  330. =head2 Output
  331.  
  332. The output looks like this:
  333.  
  334.    ...
  335. IO::Socket         (1.28)  Object interface to socket communications
  336. IO::Socket::INET   (1.27)  Object interface for AF_INET domain sockets
  337. IO::Socket::UNIX   (1.21)  Object interface for AF_UNIX domain sockets
  338. IO::Stty           (n/a)   <description not available>
  339. IO::Tty            (1.02)  Low-level allocate a pseudo-Tty, import constants.
  340. IO::Tty::Constant  (n/a)   Terminal Constants (autogenerated)
  341.    ...
  342.  
  343. The three parts module name, version and description are separated
  344. by at least one blank.
  345.  
  346. =head1 REQUIREMENTS
  347.  
  348. ExtUtils::MakeMaker, File::Find, Getopt::Std
  349.  
  350. =head1 BUGS AND LIMITATIONS
  351.  
  352. The command line switch -s (sort) is not available under non-UNIX operating
  353. systems.  An additional shell sort command can be used.
  354.  
  355. There are no known bugs in this module.
  356.  
  357. Please report problems to Fritz Mehner, mehner@fh-swf.de .
  358.  
  359. =head1 AUTHORS
  360.  
  361.   Tom Christiansen, tchrist@perl.com (pmdesc)
  362.   Aristotle, http://qs321.pair.com/~monkads/ (pmdesc2)
  363.   Fritz Mehner, mehner@fh-swf.de (pmdesc3.pl)
  364.  
  365. =head1 NOTES
  366.  
  367. pmdesc3.pl is based on pmdesc2 (Aristotle, http://qs321.pair.com/~monkads/).
  368. pmdesc3.pl adds extensions and bugfixes.
  369.  
  370. pmdesc2 is based on pmdesc (Perl Cookbook, 1. Ed., recipe 12.19).
  371. pmdesc2 is at least one magnitude faster than pmdesc.
  372.  
  373. =head1 VERSION
  374.  
  375. 1.2.3
  376.  
  377. =cut
RAW Paste Data
Top