home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-convex / man.shar / man / cfman < prev    next >
Encoding:
Text File  |  1991-03-04  |  9.9 KB  |  403 lines
  1. #!/usr/local/bin/perl
  2. #
  3. # cfman v2.0: man page cross-referencer
  4. # author: Tom Christiansen <tchrist@convex.com>
  5. # date: 15 November 89
  6. #
  7. # usage: cfman [ -d debug-devel ] [ -s sub-sections ] 
  8. #           [ -p manpath ] [ -x xrefpath ] 
  9.  
  10. ($iam = $0) =~ s%.*/%%;
  11.  
  12. $] =~ /(\d+\.\d+).*\nPatch level: (\d+)/;
  13. die "$iam: requires at least perl version 3.0, patchlevel 1 to run correctly\n"
  14.     if $1 < 3.0 || ($1 == 3.0 && $2 < 1);
  15.     
  16.  
  17. require 'getopts.pl';
  18.  
  19. &Getopts('d:s:p:P:x:') || &usage;
  20.  
  21. $manpath = $opt_p if defined $opt_p;
  22. $manpath = $opt_P if defined $opt_P;
  23. $manpath = $ENV{'MANPATH'} unless $manpath;
  24. $manpath = "/usr/man" unless $manpath;
  25. @manpath = split(/:/,$manpath);
  26.  
  27. $opt_x =~ /^:/ && ( $opt_x = $manpath . $opt_x );
  28. @xrefpath = $opt_x ? split(/:/,$opt_x) : @manpath;
  29.  
  30. $debug = $opt_d;
  31.  
  32. @sections = $opt_s ? split(/ */,$opt_s) : 1..8;
  33.  
  34. if ($debug) {
  35.     $" = ':';
  36.     print "manpath is @manpath\n";
  37.     print "xrefpath is @xrefpath\n";
  38.     $" = ' ';
  39. } 
  40.  
  41. file:    foreach $file ( $#ARGV >= $[ ? @ARGV : '*.*' ) {
  42.          printf STDERR "considering %s\n", $file if $debug & 1;
  43.          $bingo = 0;
  44. tree:        foreach $tree ( @manpath ) {
  45.          print "ROOT is $tree\n" if $debug;
  46.          if (!chdir $tree) {
  47.             warn "cannot chdir to $tree: $!";
  48.             next tree;
  49.          } 
  50.          $rootdir = $tree;
  51.          if ( $file =~ m#^/# ) {
  52.             &read_manpages($file); 
  53.             next file;
  54.          } 
  55. section:         foreach $section ( @sections ) {
  56.             &scan_section($tree,$section,$file);
  57.          }
  58.          } 
  59.          print "no man pages matched \"$file\"\n" unless $bingo;
  60.       }
  61.  
  62.  
  63. exit 0;
  64.  
  65. ############################################################################
  66. #
  67. # scan_section()
  68. #
  69. #    checks a given man tree (like /usr/local/man) in a 
  70. #    certain subsection (like '1'), checking for a certain
  71. #    file, like 'tty' (which mean 'tty.*', 'system.3*', or '*.*'.
  72. #
  73. #    will recurse on a subsection name contaning a shell meta-character
  74. #
  75. ############################################################################
  76.  
  77. sub scan_section {
  78.     local ( $manroot, $subsec, $files ) = @_;
  79.     local ( $mandir );
  80.  
  81.     $mandir = "man" . $subsec;
  82.  
  83.  
  84.     # subsec may have been ? or *; if so, recurse!
  85.     if ( &has_meta($mandir) ) {  
  86.     for (<${mandir}>) {
  87.         if (&has_meta($_)) { 
  88.         warn "bad glob of $mandir"; 
  89.         last; 
  90.         } 
  91.         s/^man//;
  92.         &scan_section($manroot,$_,$files);
  93.     } 
  94.     return;
  95.     } 
  96.  
  97.     $files = "$files.*" unless $files =~ /\./;
  98.  
  99.     if (!chdir $mandir) {
  100.     warn "couldn't chdir to $mandir: $!\n" if $debug;
  101.     return;
  102.     } 
  103.  
  104.     printf STDERR "chdir to %s of %s\n", $mandir, $manroot if $debug & 1;
  105.  
  106.     &read_manpages ( &has_meta($files) ? &glob($files) : ($files));
  107.  
  108.     chdir('..');
  109. } 
  110.  
  111. ############################################################################
  112. #
  113. # read_manpages()
  114. #
  115. #    passed a list of filename, which are man pages.  opens each one
  116. #    verifying that the file really is in the place that the .TH line.
  117. #    skips to SEE ALSO section and then verifies existence of each 
  118. #    referenced man page.
  119. ############################################################################
  120.  
  121.  
  122. sub read_manpages {
  123.     local (@pages) = @_;
  124.  
  125.     local ($junk, $sopage, $basename, $line, $page, $pname, $pext, $gotTH);
  126.     local(%seen);
  127.  
  128.  
  129. page:
  130.     foreach $page ( @pages ) {
  131.     next page if $page =~ /\.(BAK|OLD)$/i;
  132.  
  133.     if ($seen{$page}++) {
  134.         print "already saw $page\n" if $debug & 1;
  135.         next page;
  136.     }
  137.  
  138.     if (!open page) {
  139.         warn "couldn't open $page: $!\n";
  140.         next page;
  141.     }
  142.  
  143.     $bingo = 1; # global var
  144.  
  145.     print "checking $page\n" if $debug & 1;
  146.  
  147.     $gotTH = 0;
  148.     $line = 0;
  149.     $sopage = '';
  150.  
  151. line:   while (<page>) {
  152.         print if $debug & 16;
  153.         next line if /^'''/ || /^\.\\"/;
  154.  
  155.         # deal with .so's on the first line.
  156.         # /usr/ucb/man uses this instead of links.
  157.         if (!($line++) && /^\.so\s+(.*)/) {
  158.         $sopage = $1;
  159.         print "$page -> $sopage\n" if $debug & 1;
  160.         ($basename = $sopage) =~ s%.*/%%;
  161.         if ($seen{$basename}++) {
  162.             print "already saw $basename\n" if $debug & 1;
  163.             next page;
  164.         } 
  165.         if (!open(page,"../$sopage")) {
  166.             print "$page: cannot open $sopage: $!\n";
  167.             next page;
  168.         } 
  169.         $page = $basename;
  170.         next line;
  171.         } 
  172.  
  173.         # check for internally consistent .TH line
  174.         if ( /^\.(TH|SC)/ ) { # SC is for mh
  175.          $gotTH++;
  176.          printf STDERR "TH checking %s", $_ if $debug & 4;
  177.          do flush();
  178.          s/"+//g;
  179.          ($junk, $pname, $pext) = split;
  180.          if (¯o($pname)) {
  181.             printf STDERR "%s: can't resolve troff macro in .TH: %s\n",
  182.                 $page, $pname;
  183.             next line;
  184.          } 
  185.          $pext =~ y/A-Z/a-z/;
  186.          $pname =~ s/\\-/-/g;
  187.          $pname =~ y/A-Z/a-z/ if $pname =~ /^[\$0-9A-Z_\055]+$/;
  188.          ($pexpr = $page) =~ s/([.+])/\\$1/g;
  189.          $pexpr =~ s%.*/%%;
  190.          if ( "$pname.$pext" !~ /^$pexpr$/i) {
  191.               printf "%s: thinks it's in %s(%s)\n", 
  192.               $page, $pname, $pext;
  193.          } 
  194.          next line;
  195.         }
  196.  
  197.         next line unless /^\.S[Hh]\s+"*SEE ALSO"*/ 
  198.         || /^\.S[Hh]\s+REFERENCES/    # damn posix
  199.         || /^\.Sa\s*$/;         # damn mh
  200.  
  201.         # finally found the cross-references
  202. xref:       while (<page>) {
  203.         print if $debug & 16;
  204.         last line if /^\.(S[Hh]|Co|Hi|Bu)/; # i really hate mh macros
  205.         next xref unless /\(/;
  206.         next xref if /^.PP/;
  207.         chop;
  208.         s/\\f[RIPB]//g;
  209.         s/\\\|//g;
  210.         s/\\-/-/g;
  211. entry:          foreach $entry ( split(/,/) ) {
  212.             #print "got entry $entry\n";
  213.             next entry unless $entry =~ /\(.*\)/;
  214.             $pname = ''; $pext = '';
  215.             $1 = ''; $2 = '';
  216.             ($pname, $pext) = 
  217.             ($entry =~ /([A-Za-z0-9\$._\-]+)\s*\(([^)]+)\).*$/); 
  218.             if ($debug & 8) {
  219.             printf STDERR "entry was %s, pname is %s, pext is %s\n",
  220.                 $entry, $pname, $pext;
  221.             }     
  222.             if (¯o($pname)) {
  223.             printf "%s: can't resolve troff macro in SEE ALSO: %s\n",
  224.                 $page, $pname;
  225.             next entry;
  226.             } 
  227.             next entry if !$pname || !$pext || $pext !~ /^\w+$/;
  228.             $pext =~ y/A-Z/a-z/;
  229.             $pname =~ y/A-Z/a-z/ if $pname =~ /^[A-Z_0-9\-]+$/;
  230.             #($psect = $pext) =~ s/^(.).*/$1/;
  231.             do check_xref($page,$pname,$pext);
  232.  
  233.         }    # entry: foreach $entry ( split(/,/) ) 
  234.         }        # xref:  while (<page>)
  235.     }        # line:  while (<page>) 
  236.     printf "%s: missing .TH\n", $page if (!$gotTH);
  237.     }              # page:  foreach $page ( @pages )
  238. }                 # sub    read_manapages
  239.  
  240.  
  241. ###########################################################################
  242. #
  243. # check_xref()
  244. #
  245. #    given the name of the page we're looking for, check for a
  246. #    cross reference of a given man page and its assumed subsection
  247. #
  248. ###########################################################################
  249.  
  250. sub check_xref {
  251.     local ($name, $target, $section) = @_;
  252.     local ($basesec, $subsec, $newsec );
  253.  
  254.     printf STDERR " xref of %s(%s)\n", $target, $section if $debug & 2;
  255.  
  256.     return if &pathcheck($target,$section);
  257.  
  258.  
  259.     # if we get this far, something's wrong, so begin notify
  260.     printf "%s: %s(%s)", $name, $target, $section;
  261.  
  262.     ($basesec, $subsec) = ($section =~ /^(\d)(.*)$/);
  263.  
  264.     if ($name =~ /\.\d*([nlp])$/ && ($section == 1 || $section == 8)
  265.         && ($newsec = &pathcheck($target,$1))) { # hack for manl idiocy
  266.     &really($target,$newsec);
  267.     return;
  268.     }
  269.  
  270.     # first check if page.Xn is really in page.X
  271.     if ( $subsec && ($newsec = &pathcheck($target,$basesec))) {
  272.     &really($target,$newsec);
  273.     return;
  274.     } 
  275.  
  276.     if ( $basesec == 1 && &pathcheck($target,8))  {
  277.     &really($target,8);
  278.     return;
  279.     }
  280.  
  281.     if ( $basesec == 8 && &pathcheck($target,1))  {
  282.     &really($target,1);
  283.     return;
  284.     }
  285.  
  286.     # maybe it thinks it's in 8 but got erroneously in 1
  287.     if ( $basesec =~ /[18]/ && ($newsec = &pathcheck($target,'l')))  {
  288.     &really($target,$newsec);
  289.     return;
  290.     } 
  291.  
  292.     # maybe page.X is really in page.Xn; this is expensive
  293.     if ( !$subsec && ($newsec = &pathcheck($target,$basesec.'*'))) {
  294.     &really($target,$newsec);
  295.     return;
  296.     } 
  297.  
  298.     printf " missing\n";
  299.     do flush();
  300. }
  301.  
  302. ###########################################################################
  303. #
  304. # pathcheck()
  305. #
  306. #    takes a name (like 'tty') and a section (like '1d')
  307. #    and looks for 'tty.1d' first in the current root, 
  308. #    then in all other elements of @xrefpath.  the section
  309. #    may have a meta-character in it (like '8*').
  310. #
  311. #    returns the subsection in which we found the page, or
  312. #    null if we failed.
  313. #
  314. ###########################################################################
  315.  
  316. sub pathcheck {
  317.     local ( $name, $section ) = @_;
  318.     local ( $basesec, $metasec, $fullpath, @expansion, $tree, %checked  ); 
  319.     local ( $return ) = 0;
  320.  
  321.     $metasec = &has_meta($section);
  322.  
  323.     ($basesec) = ($section =~ /^(.)/);
  324.  
  325.     foreach $tree ( $rootdir, @xrefpath ) {
  326.     next if !$tree || $checked{$tree}++;  # only check each tree once
  327.  
  328.     $fullpath = "$tree/man$basesec/$name.$section";  
  329.  
  330.     print "   testing $fullpath\n" if $debug & 8;
  331.  
  332.     if (!$metasec) {
  333.         if (-e $fullpath) {
  334.         $return = $section;
  335.         }
  336.     } else {
  337.         open(SAVERR, '>&STDERR');  # csh globbing brain damage
  338.         close STDERR;
  339.         if ((@expansion = <${fullpath}>) && !&has_meta($expansion[0])) {
  340.                     # redundant meta check due to sh brain-damage
  341.         #for (@expansion) { s/.*\.//; } 
  342.         #$section = join(' or ',@expansion);
  343.         ($section) = ($expansion[0] =~ /([^.]+)$/);
  344.         $return = $section;
  345.         }
  346.         open(STDERR, '>&SAVERR');  # csh globbing brain damage
  347.         close SAVERR;
  348.     }
  349.     } 
  350.     printf STDERR "   pathcheck returns $section\n" if $debug & 8;
  351.     $return;
  352. } 
  353.  
  354. #---------------------------------------------------------------------------
  355.  
  356. sub flush {
  357.     $| = 1; 
  358.     print ''; 
  359.     $| = 0;
  360. }
  361.  
  362. sub has_meta {
  363.     $_[0] =~ /[[*?]/;
  364. } 
  365.  
  366. sub macro {
  367.     @_[0] =~ /^\\\*\(/;
  368. } 
  369.  
  370. sub really {
  371.     local($was,$is) = @_;
  372.     print " really in $was($is)\n";
  373. }
  374.  
  375. sub usage {
  376.     die "usage: $iam [-d debug-level] [-s sub-sections] [-p manpath] 
  377.         [-x xrefpath] [pattern ...] \n";
  378. }
  379.  
  380. sub glob {
  381.     local($expr) = @_;
  382.     local(@retlist) = ();
  383.     local(*METADIR);                # paranoia
  384.  
  385.     die "glob: null expr" unless $expr;        # assert
  386.  
  387.     if ($expr =~ /\//) {
  388.     warn "glob: \"$expr\" has slashes, punting...";
  389.     return <${expr}>;
  390.     } 
  391.  
  392.     $expr =~ s/\*/.*/g;
  393.     $expr =~ s/\?/./g;
  394.  
  395.     unless (opendir(METADIR, '.')) {
  396.     warn "glob: can't opendir ".": $!\n";
  397.     } else {
  398.     @retlist = sort grep(/$expr/o, grep(!/^\./, readdir(METADIR)));
  399.     closedir METADIR;
  400.     }
  401.     return @retlist;
  402. } 
  403.