runtime/tools/shtags.pl

   1 #!/usr/bin/env perl
   2 #
   3 # shtags: create a tags file for perl scripts
   4 #
   5 # Author:       Stephen Riehm
   6 # Last Changed: 96/11/27 19:46:06
   7 #
   8 # "@(#) shtags 1.1 by S. Riehm"
   9 #
  10
  11 # obvious... :-)
  12 sub usage
  13     {
  14     print <<_EOUSAGE_ ;
  15 USAGE: $program [-kvwVx] [-t <file>] <files>
  16     -t <file>   Name of tags file to create. (default is 'tags')
  17     -s <shell>  Name of the shell language in the script
  18     -v          Include variable definitions.
  19                 (variables mentioned at the start of a line)
  20     -V          Print version information.
  21     -w          Suppress "duplicate tag" warnings.
  22     -x          Explicitly create a new tags file. Normally tags are merged.
  23     <files>     List of files to scan for tags.
  24 _EOUSAGE_
  25     exit 0
  26     }
  27
  28 sub version
  29 {
  30     #
  31     # Version information
  32     #
  33     @id = split( ', ', 'scripts/bin/shtags, /usr/local/, LOCAL_SCRIPTS, 1.1, 96/11/27, 19:46:06' );
  34     $id[0] =~ s,.*/,,;
  35     print <<_EOVERS;
  36 $id[0]:         $id[3]
  37 Last Modified:  @id[4,5]
  38 Component:      $id[1]
  39 Release:        $id[2]
  40 _EOVERS
  41     exit( 1 );
  42 }
  43
  44 #
  45 # initialisations
  46 #
  47 ($program = $0) =~ s,.*/,,;
  48 require 'getopts.pl';
  49
  50 #
  51 # parse command line
  52 #
  53 &Getopts( "t:s:vVwx" ) || &usage();
  54 $tags_file = $opt_t || 'tags';
  55 $explicit = $opt_x;
  56 $variable_tags = $opt_v;
  57 $allow_warnings = ! $opt_w;
  58 &version          if $opt_V;
  59 &usage()        unless @ARGV != 0;
  60
  61 # slurp up the existing tags. Some will be replaced, the ones that aren't
  62 # will be re-written exactly as they were read
  63 if( ! $explicit && open( TAGS, "< $tags_file" ) )
  64     {
  65     while( <TAGS> )
  66         {
  67         /^\S+/;
  68         $tags{$&} = $_;
  69         }
  70     close( TAGS );
  71     }
  72
  73 #
  74 # for each line of every file listed on the command line, look for a
  75 # 'sub' definition, or, if variables are wanted aswell, look for a
  76 # variable definition at the start of a line
  77 #
  78 while( <> )
  79     {
  80     &check_shell($_), ( $old_file = $ARGV ) if $ARGV ne $old_file;
  81     next unless $shell;
  82     if( $shell eq "sh" )
  83         {
  84         next    unless /^\s*(((\w+)))\s*\(\s*\)/
  85                     || ( $variable_tags && /^(((\w+)=))/ );
  86         $match = $3;
  87         }
  88     if( $shell eq "ksh" )
  89         {
  90         # ksh
  91         next    unless /^\s*function\s+(((\w+)))/
  92                     || ( $variable_tags && /^(((\w+)=))/ );
  93         $match = $3;
  94         }
  95     if( $shell eq "perl" )
  96         {
  97         # perl
  98         next    unless /^\s*sub\s+(\w+('|::))?(\w+)/
  99                     || /^\s*(((\w+))):/
 100                     || ( $variable_tags && /^(([(\s]*[\$\@\%]{1}(\w+).*=))/ );
 101         $match = $3;
 102         }
 103     if( $shell eq "tcl" )
 104         {
 105         next    unless /^\s*proc\s+(((\S+)))/
 106                     || ( $variable_tags && /^\s*set\s+(((\w+)\s))/ );
 107         $match = $3;
 108         }
 109     chop;
 110     warn "$match - duplicate ignored\n"
 111         if ( $new{$match}++
 112             || !( $tags{$match} = sprintf( "%s\t%s\t?^%s\$?\n", $match, $ARGV, $_ ) ) )
 113             && $allow_warnings;
 114     }
 115
 116 # write the new tags to the tags file - note that the whole file is rewritten
 117 open( TAGS, "> $tags_file" );
 118 foreach( sort( keys %tags ) )
 119     {
 120     print TAGS "$tags{$_}";
 121     }
 122 close( TAGS );
 123
 124 sub check_shell
 125     {
 126     local( $_ ) = @_;
 127     # read the first line of a script, and work out which shell it is,
 128     # unless a shell was specified on the command line
 129     #
 130     # This routine can't handle clever scripts which start sh and then
 131     # use sh to start the shell they really wanted.
 132     if( $opt_s )
 133         {
 134         $shell = $opt_s;
 135         }
 136     else
 137         {
 138         $shell = "sh"   if /^:$/ || /^#!.*\/bin\/sh/;
 139         $shell = "ksh"  if /^#!.*\/ksh/;
 140         $shell = "perl" if /^#!.*\/perl/;
 141         $shell = "tcl"  if /^#!.*\/wish/;
 142         printf "Using $shell for $ARGV\n";
 143         }
 144     }