|
7
|
1 #!/usr/bin/env perl
|
|
|
2 #
|
|
|
3 # shtags: create a tags file for perl scripts
|
|
|
4 #
|
|
|
5 # Author: Stephen Riehm
|
|
13589
|
6 # Updated by: David Woodfall <dave@dawoodfall.net>
|
|
|
7 # Last Changed: 2018/04/02
|
|
7
|
8 #
|
|
13589
|
9
|
|
|
10 use Getopt::Std;
|
|
7
|
11
|
|
|
12 # obvious... :-)
|
|
|
13 sub usage
|
|
|
14 {
|
|
|
15 print <<_EOUSAGE_ ;
|
|
|
16 USAGE: $program [-kvwVx] [-t <file>] <files>
|
|
|
17 -t <file> Name of tags file to create. (default is 'tags')
|
|
|
18 -s <shell> Name of the shell language in the script
|
|
|
19 -v Include variable definitions.
|
|
|
20 (variables mentioned at the start of a line)
|
|
|
21 -V Print version information.
|
|
|
22 -w Suppress "duplicate tag" warnings.
|
|
|
23 -x Explicitly create a new tags file. Normally tags are merged.
|
|
|
24 <files> List of files to scan for tags.
|
|
|
25 _EOUSAGE_
|
|
|
26 exit 0
|
|
|
27 }
|
|
|
28
|
|
|
29 sub version
|
|
|
30 {
|
|
|
31 #
|
|
|
32 # Version information
|
|
|
33 #
|
|
13589
|
34 @id = split( ', ', 'scripts/bin/shtags, /usr/local/, LOCAL_SCRIPTS, 1.2, 18/04/02, 07:37' );
|
|
7
|
35 $id[0] =~ s,.*/,,;
|
|
|
36 print <<_EOVERS;
|
|
|
37 $id[0]: $id[3]
|
|
|
38 Last Modified: @id[4,5]
|
|
|
39 Component: $id[1]
|
|
|
40 Release: $id[2]
|
|
|
41 _EOVERS
|
|
|
42 exit( 1 );
|
|
|
43 }
|
|
|
44
|
|
|
45 #
|
|
|
46 # initialisations
|
|
|
47 #
|
|
|
48 ($program = $0) =~ s,.*/,,;
|
|
|
49
|
|
|
50 #
|
|
|
51 # parse command line
|
|
|
52 #
|
|
13589
|
53 getopts( "t:s:vVwx" ) || &usage();
|
|
7
|
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 }
|
