| [2759] | 1 | #!/bin/perl |
|---|
| 2 | |
|---|
| 3 | $dbdir = "tools/code_dbase" ; |
|---|
| 4 | |
|---|
| 5 | if ( ! opendir( TOOLDIR, "tools") ) { |
|---|
| 6 | print "\nMust be in top level WRF directory\n" ; |
|---|
| 7 | exit ; |
|---|
| 8 | } |
|---|
| 9 | closedir TOOLDIR ; |
|---|
| 10 | |
|---|
| 11 | $gofast=0 ; |
|---|
| 12 | if ( ( scalar @ARGV < 1 ) || ( scalar @ARGV > 2 ) ) { |
|---|
| 13 | print "usage: subinfo routinename \n" ; |
|---|
| 14 | print " subinfo rebuild \n" ; |
|---|
| 15 | exit ; |
|---|
| 16 | } |
|---|
| 17 | if ( ( scalar @ARGV == 2 ) ) { $gofast = 1 ; } # don't bother with links for argument lists |
|---|
| 18 | |
|---|
| 19 | if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" ) |
|---|
| 20 | { |
|---|
| 21 | print "Building code database ... please wait.\n" ; |
|---|
| 22 | system( "cd tools/CodeBase ; make" ) ; |
|---|
| 23 | open P, "tools/build_codebase |&" ; while (<P>) { print ; } close P ; |
|---|
| 24 | system( "ln -sf tools/subinfo ." ) ; |
|---|
| 25 | system( "ln -sf tools/wrfvar ." ) ; |
|---|
| 26 | if ( $ARGV[0] eq "rebuild" ) { exit ; } |
|---|
| 27 | } |
|---|
| 28 | close XXX ; |
|---|
| 29 | |
|---|
| 30 | |
|---|
| 31 | $rout1 = lc $ARGV[0] ; |
|---|
| 32 | $rout = $rout1 ; |
|---|
| 33 | #print $vname,"\n" ; |
|---|
| 34 | #print $rout,"\n" ; |
|---|
| 35 | |
|---|
| 36 | $routfile = $dbdir."/".$rout ; |
|---|
| 37 | |
|---|
| 38 | if ( ! ( open( ROUT, "< $routfile" )) ) { |
|---|
| 39 | print "$rout is not a known subprogram. \n" ; |
|---|
| 40 | open P, "/bin/ls -1 $dbdir/\*$rout\* | " ; |
|---|
| 41 | print "Perhaps you mean:\n" ; |
|---|
| 42 | while (<P>) { |
|---|
| 43 | s/.*\/// ; |
|---|
| 44 | if ( substr( $_, 0, 3 ) eq "lm_" ) { next ; } |
|---|
| 45 | if ( $_ =~ "not found" ) { break ; } |
|---|
| 46 | print " $_" ; |
|---|
| 47 | } |
|---|
| 48 | exit ; |
|---|
| 49 | } |
|---|
| 50 | |
|---|
| 51 | #open ROUT, "< $routfile" or { print "$rout is not a known subprogram. Perhaps you mean:\n" ; } |
|---|
| 52 | # system( "/bin/ls -1 $dbdir/\*$rout\*" ) ; |
|---|
| 53 | # die ; |
|---|
| 54 | |
|---|
| 55 | while ( <ROUT> ) { |
|---|
| 56 | @t = split ' ' ; |
|---|
| 57 | if ( $t[0] eq sourcefile ) { |
|---|
| 58 | $sourcefile = $t[1] ; |
|---|
| 59 | } |
|---|
| 60 | if ( $t[0] eq subprogram ) { |
|---|
| 61 | if ( $t[1] eq "function" ) { |
|---|
| 62 | $subprog = $t[2]." ".$t[1] ; |
|---|
| 63 | } else { |
|---|
| 64 | $subprog = $t[1] ; |
|---|
| 65 | } |
|---|
| 66 | } |
|---|
| 67 | } |
|---|
| 68 | close ROUT ; |
|---|
| 69 | |
|---|
| 70 | print "<html>\n" ; |
|---|
| 71 | print "<title> ",ucfirst $subprog," : ",uc $rout1," </title>\n" ; |
|---|
| 72 | print "<body>\n" ; |
|---|
| 73 | print "<h1> ",ucfirst $subprog," : ",uc $rout1," </h1> \n" ; |
|---|
| 74 | |
|---|
| 75 | # see if there is a 'big-f' file... |
|---|
| 76 | $refer_to = $sourcefile ; |
|---|
| 77 | $tail = substr( $sourcefile, length( $sourcefile ) - 2 ) ; |
|---|
| 78 | if ( "$tail" eq ".f" ) { |
|---|
| 79 | $refer_to = substr( $sourcefile, 0, length( $sourcefile ) - 2 ) . ".F" ; |
|---|
| 80 | if ( ! ( open( EXISTNCE, "< $refer_to" )) ) { |
|---|
| 81 | $refer_to = $sourcefile ; |
|---|
| 82 | } |
|---|
| 83 | else { close EXISTNCE ; } |
|---|
| 84 | } |
|---|
| 85 | |
|---|
| 86 | #print "<b> Defined in: </b> <a href=\"../../$refer_to\"> $refer_to </a> <p> <p>\n" ; |
|---|
| 87 | # have it point to the wrf code browser instead |
|---|
| 88 | $rout1_uc = uc $rout1 ; |
|---|
| 89 | print "<b> Defined in: </b> <a href=\"../../../wrfbrowser/html_code/${refer_to}.html#$rout1_uc\"> $refer_to </a> <p> <p>\n" ; |
|---|
| 90 | |
|---|
| 91 | if ( open (DESC, "< ${routfile}_descrip" ) ) { |
|---|
| 92 | print "<b> Description: </b><p>\n" ; |
|---|
| 93 | while ( <DESC> ) { |
|---|
| 94 | print ; |
|---|
| 95 | } |
|---|
| 96 | print "<p>\n" ; |
|---|
| 97 | close DESC ; |
|---|
| 98 | } |
|---|
| 99 | |
|---|
| 100 | |
|---|
| 101 | print "<b> Called by : </b> <p> <p>\n" ; |
|---|
| 102 | print "<pre>\n" ; |
|---|
| 103 | @sysargs = ( "tools/subinfo_calls", 0, "$rout" ) ; |
|---|
| 104 | open BBB , "tools/subinfo_calls 0 $rout | " ; |
|---|
| 105 | while ( <BBB> ) { print ; } |
|---|
| 106 | close BBB ; |
|---|
| 107 | print "</pre>\n" ; |
|---|
| 108 | |
|---|
| 109 | $first=1 ; |
|---|
| 110 | $use_entry = 0 ; |
|---|
| 111 | open ROUT, "< $routfile" or die "can not open $routfile" ; |
|---|
| 112 | while ( <ROUT> ) { |
|---|
| 113 | @t = split ' ' ; |
|---|
| 114 | if ( $t[0] eq "use" ) { |
|---|
| 115 | if ( $first == 1 ) { |
|---|
| 116 | print "<b> Uses: </b> <p> <p>\n<pre>\n" ; |
|---|
| 117 | $use_entry = 1 ; |
|---|
| 118 | $first = 0 ; |
|---|
| 119 | } |
|---|
| 120 | printf(" %-30s ",uc $t[1] ) ; |
|---|
| 121 | open P,"/bin/ls */*.F | grep -w $t[1] |" ; |
|---|
| 122 | while( <P> ) { |
|---|
| 123 | chop ; |
|---|
| 124 | # printf("(<a href=\"../../%s\">%s</a>)\n", $_, $_ ) ; |
|---|
| 125 | printf("(<a href=\"../../../wrfbrowser/html_code/%s.html#%s\">%s</a>)\n", $_, uc $t[1], $_ ) ; |
|---|
| 126 | } |
|---|
| 127 | close P ; |
|---|
| 128 | } |
|---|
| 129 | } |
|---|
| 130 | if ( $use_entry == 1 ) { print "</pre>\n" ; } |
|---|
| 131 | close ROUT ; |
|---|
| 132 | |
|---|
| 133 | print "<b> Arguments: </b> <p> <p>\n" ; |
|---|
| 134 | print "<pre>\n" ; |
|---|
| 135 | |
|---|
| 136 | open ROUT, "< $routfile" or die "can not open $routfile" ; |
|---|
| 137 | $i = 1 ; |
|---|
| 138 | while ( <ROUT> ) { |
|---|
| 139 | @t = split ' ' ; |
|---|
| 140 | if ( $t[0] eq arg && $t[9] eq dummyarg ) { |
|---|
| 141 | printf("%3d.",$i++) ; |
|---|
| 142 | $vfile = "$dbdir/vv_" . $rout1 . "_" . $t[3] . ".html" ; |
|---|
| 143 | if ( $gofast == 0 ) { |
|---|
| 144 | system ( "echo '<html><pre>' > $vfile ; tools/wrfvar $t[3] $rout1 >> $vfile ; echo '</pre></html>' >> $vfile" ) ; |
|---|
| 145 | } |
|---|
| 146 | $intent = "INTENT( ".uc $t[7]." )" ; |
|---|
| 147 | if ( $t[11] ne "" ) { |
|---|
| 148 | $dims = "DIMENSION( ".$t[11]." )" ; |
|---|
| 149 | $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ; |
|---|
| 150 | printf(" <a href=\"%s\">%-12s</a> :: %-8s, %-16s, %s\n",$vfile,$t[3], uc $t[5], $intent, $dims ) ; |
|---|
| 151 | } else { |
|---|
| 152 | $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ; |
|---|
| 153 | printf(" <a href=\"%s\">%-12s</a> :: %-8s, %-16s\n",$vfile,$t[3], uc $t[5], $intent ) ; |
|---|
| 154 | } |
|---|
| 155 | } |
|---|
| 156 | } |
|---|
| 157 | close ROUT ; |
|---|
| 158 | print "</pre>\n" ; |
|---|
| 159 | |
|---|
| 160 | $first = 1 ; |
|---|
| 161 | open CALLEES, "< $dbdir/calls" or die " cannot open $dbdir/calls " ; |
|---|
| 162 | while ( <CALLEES> ) { |
|---|
| 163 | @t = split ' ' ; |
|---|
| 164 | if ( $t[0] eq lc $rout && $t[1] eq calls && ! ($t[2] =~ add_msg) && !($t[2] =~ reset_msgs) && !($t[2] =~ stencil) && !($t[2] =~ wrf_debug) |
|---|
| 165 | && (substr($t[2],0,4) ne "get_") ) { |
|---|
| 166 | if ( $first == 1 ) { |
|---|
| 167 | print "<b>",uc $rout," calls : </b> <p> <p>\n" ; |
|---|
| 168 | # print "<pre>\n" ; |
|---|
| 169 | print "<table>\n" ; |
|---|
| 170 | $first = 2 ; |
|---|
| 171 | } |
|---|
| 172 | open C ,"< $dbdir/$t[2]" ; |
|---|
| 173 | while ( <C> ) { |
|---|
| 174 | @u = split ' ' ; |
|---|
| 175 | if ( $u[0] eq sourcefile ) { $sf = $u[1] ; break ; } |
|---|
| 176 | } |
|---|
| 177 | close C ; |
|---|
| 178 | # see if there is a 'big-f' file... |
|---|
| 179 | $refer_to = $sf ; |
|---|
| 180 | $tail = substr( $sf, length( $sf ) - 2 ) ; |
|---|
| 181 | if ( "$tail" eq ".f" ) { |
|---|
| 182 | $refer_to = substr( $sf, 0, length( $sf ) - 2 ) . ".F" ; |
|---|
| 183 | if ( ! ( open( EXISTNCE, "< $refer_to" )) ) { |
|---|
| 184 | $refer_to = $sf ; |
|---|
| 185 | } |
|---|
| 186 | else { close EXISTNCE ; } |
|---|
| 187 | } |
|---|
| 188 | $sf = $refer_to ; |
|---|
| 189 | printf("<tr><td><a href=\"%s\.html\">%30s</a></td><td>(<a href=\"../../%s\">%s</a>)</td></tr>\n",$t[2], $t[2],$sf,$sf) ; |
|---|
| 190 | } |
|---|
| 191 | } |
|---|
| 192 | if ( $first == 2 ) { |
|---|
| 193 | print "</table>\n" ; |
|---|
| 194 | } |
|---|
| 195 | |
|---|
| 196 | |
|---|
| 197 | |
|---|
| 198 | print "</html>\n" ; |
|---|
| 199 | |
|---|
| 200 | exit |
|---|
| 201 | |
|---|
| 202 | #if ( $found_var == 0 ) { |
|---|
| 203 | # print uc $vname , "is not an argument to ${rout1}. May be local or use-associated.\n" ; |
|---|
| 204 | # print ucfirst $rout1," has $nargs_rout arguments.\n" ; |
|---|
| 205 | # close ROUT ; |
|---|
| 206 | # open ROUT, "< $routfile" or die "can not open $routfile" ; |
|---|
| 207 | # while ( <ROUT> ) |
|---|
| 208 | # { |
|---|
| 209 | # s/^ *// ; |
|---|
| 210 | # s/ */ /g ; |
|---|
| 211 | # @t = split ' ' ; |
|---|
| 212 | # if ( $t[0] eq "arg" ) { |
|---|
| 213 | # $i = $t[1] + 1 ; |
|---|
| 214 | # printf("%3d. ",$i) ; |
|---|
| 215 | # print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ; |
|---|
| 216 | # } |
|---|
| 217 | # } |
|---|
| 218 | # close ROUT ; |
|---|
| 219 | #} |
|---|
| 220 | |
|---|
| 221 | |
|---|
| 222 | |
|---|
| 223 | |
|---|
