1#!/usr/bin/perl 2# $Id: call-anal.pl,v 1.8 2009-08-25 16:22:44 sampo Exp $ 3# 16.6.2003, Sampo Kellomaki <sampo@iki.fi> 4# 25.6.2003, fixed C++ destructor handling, improved origin centered call graphs --Sampo 5# 14.12.2003, added function number initialization facility --Sampo 6# 4.10.2008, added capability to extract documentation comments --Sampo 7# 2.6.2009, optimize away single node call graphs --Sampo 8# 9# Perform total call graph analysis 10# - produce graph with graphviz 11# - annotate the source with comments to effect /* Called by: ... */ 12# 13# Some simplifying assumptions are made: 14# - Function calls are assumed to be of form 15# func(...), or 16# name::space::func(...), or 17# ->func(...), or 18# .func(...) 19# - Function definitions are assumed to be of form 20# type func(struct... 21# type func(int... 22# type func(void... 23 24$usage = <<USAGE; 25Usage: ./call-anal.pl [opts] */*.c */*.cc >graph.dot 26 -n perform simulation, do not alter the source 27 28dot -Tps graph.dot -o graph.ps && gv graph.ps 29http://www.research.att.com/sw/tools/graphviz/download.html 30USAGE 31 ; 32 33$project = 'ZXID'; 34 35$dot_header = <<DOT; 36// Generated graph. Do not edit. Any changes will be lost. 37// dot -Tps graph.dot -o graph.ps && gv graph.ps 38// http://www.research.att.com/sw/tools/graphviz/download.html 39DOT 40 ; 41 42$write = 1; 43if ($ARGV[0] eq '-n') { 44 shift; 45 $write = 0; 46} 47die $USAGE if $ARGV[0] =~ /^-/; 48undef $/; 49 50# Function at origin of graph => call depth from the function 51#%local_graphs = ( main => 6, # the start 52# yyparse => 3, # center of compiler 53# ); 54%local_graphs = ( hi_shuffle => 10, 55 zxbus_listen_msg => 4, 56 zxid_simple_cf => 4); 57 58# N.B. names in all upper case, i.e. macros, are always ignored 59@ignore_callee = qw(for if return sizeof switch while); 60push @ignore_callee, 61 qw(accept atoi close fclose fcntl fprintf fputs ftruncate free 62 getpid getuid getegid htons htonl getenv gmtime_r inetaton 63 lseek dlsym dlopen 64 malloc memchr memcpy memcmp memmove memset mmap munmap 65 new open printf poll 66 closedir opendir rewinddir pow 67 perror pthread_mutex_init pthread_mutex_lock pthread_mutex_unlock 68 pthread_cancel pthread_detach pthread_setcanceltype pthread_setspecific 69 read sleep sort sprintf strcat strchr strcmp strcpy strdup strerror 70 sscanf strlen strncmp strncpy strspn strtok toupper tolower 71 va_end va_start vprintf vsnprintf vsprintf vsyslog 72 write writev); 73 74push @ignore_callee, 75 qw(name_from_path vname_from_path open_fd_from_path vopen_fd_from_path close_file 76 zx_CreateFile write_all_fd write_all_fd_fmt 77 write_all_path_fmt write2_or_append_lock_c_path 78 read_all_fd read_all hexdump read_all_alloc get_file_size 79 sha1_safe_base64 zxid_nice_sha1 80 zx_strf zx_ref_str zx_ref_len_str zx_dup_str zx_dup_len_str zx_dup_cstr 81 zx_new_len_str zx_str_to_c 82 zx_ref_attr zx_ref_len_attr zx_attrf zx_dup_attr zx_dup_len_attr 83 zx_new_str_elem zx_ref_elem zx_ref_len_elem 84 zx_url_encode zx_url_encode_len zx_url_encode_raw unbase64_raw 85 zx_rand zx_report_openssl_err zx_memmem zxid_mk_self_sig_cert zxid_extract_private_key ); 86 87push @ignore_callee, 88 qw(hi_pdu_alloc hi_dump nonblock setkernelbufsizes zxid_get_ent_ss zx_pw_authn 89 xmtp_decode_resp test_ping http_decode smtp_decode_req smtp_decode_resp ); 90 91push @ignore_callee, qw(new_zx_ei); 92 93select STDERR; $|=1; select STDOUT; 94 95sub process_func { 96 my ($fn, $func, $body) = @_; 97 #warn "process_func($fn,$func,".length($body).")"; 98 $func =~ s/^~/D_/; 99 push @{$def{$func}}, $fn; # where is function defined 100 push @{$funcs_in_file{$fn}}, $func; 101 102 ### Analyze body to detect function calls: first eliminate confusing junk 103 104 $body =~ s{/\*.*?\*/}{}gs; # strip comments 105 $body =~ s{"[^\n\"]+?"}{}gs; # strip strings (debug output) 106 $body =~ s{if\s*\(}{}gs; 107 $body =~ s{while\s*\(}{}gs; 108 $body =~ s{for\s*\(}{}gs; 109 $body =~ s{switch\s*\(}{}gs; 110 111 # 01 1 0 112 @func_calls = $body =~ m%((~?\w+)\s*\()%sg; 113 while (@func_calls) { 114 $callee = $func_calls[1]; 115 next if $callee =~ /^[A-Z0-9_]+$/; # Ignore macros 116 next if $callee =~ /^[A-Z0-9_]{3,}/; # Ignore all caps starts 117 next if grep $callee eq $_, @ignore_callee; 118 $callee =~ s/^~/D_/; 119 #warn "zxlex2() body: >$callee< >>$func_calls[0]<<" if $func eq 'zxlex2'; 120 $called_by{$callee}{$func}++; 121 $calls{$func}{$callee}++; 122 #warn "zx_scan_identifier x zxlex2: `$called_by{$callee}{$func}' `$calls{$func}{$callee}'" if ($func eq 'zxlex2') && ($callee eq 'zx_scan_identifier'); 123 $fnf{$fn}{$func}{$callee}++; 124 #warn "fn=$fn func=$func callee=$callee: $fnf{$fn}{$func}{$callee}"; 125 } continue { 126 splice @func_calls, 0, 2; 127 } 128} 129 130#$watch1 = 'zxid_extract_issuer'; # zxiddec.c 131#$watch2 = 'zxid_decode_redir_or_post'; # zxiddec.c 132 133sub process_doc { 134 my ($fn, $func, $doc_flag, $doc, $params) = @_; 135 return if $doc_flag =~ /-/; # (-) suppresses function from documentation 136 warn "DOC1 FUNC($func) ($doc)" if $func eq $watch1 || $func eq $watch2; 137 #$doc =~ s/\n\/\*\sCalled\sby:[^\*\/]*?\*\/)?//; 138 $doc =~ s/\n\/\*\sCalled\sby:.*$//s; 139 warn "DOC2($doc)" if $func eq $watch1 || $func eq $watch2; 140 $doc =~ s/\*\/$//gs; 141 warn "DOC3($doc)" if $func eq $watch1 || $func eq $watch2; 142 $doc =~ s/\n ?\* ?/\n/gs; 143 warn "DOC4($doc)" if $func eq $watch1 || $func eq $watch2; 144 $local_graphs{$func} = 1; # Cause call graph (2 deep) to be generated for this function 145 ++$n_fn; 146 $params =~ s%\/\*.*?\*\/%%g; # zap comments 147 my @param = split /\s*,\s*/, $params; 148 for $_ (@param) { 149 s%^[\w\*:\[\]\s\/.&]+?[\t ]+\**(\w+)[\[\]]*([\t ]*=[\w:.-]*?)?$%$1%g; 150 } 151 $params = join ', ', @param; 152 my $javaname = $func; 153 $javaname =~ s%^zxid_%%; 154 $javaname = "Java name: zxidjni.$javaname()"; 155 my $perlname = $func; 156 $perlname =~ s%^zxid_%%; 157 $perlname = "Perl name: Net::SAML::$perlname()"; 158 my $src_file = "Source file: $fn" unless $no_srcfile; 159 #<<img: $func-call,H,: Call graph for $func()>> 160 my $img = qq(<<img: $func-call,R: >>) if $call_size{$func}; 161 open F, ">ref/$func.pd" or die "Can't write(ref/func.pd): $!"; 162 print F <<PD; 1631.3.$n_fn $func($params) 164~~~~~~~~~~~~~~~~~~~~ 165 166$doc 167 168$javaname 169 170$perlname 171 172$src_file 173 174$img 175 176PD 177; 178 close F; 179 180 $doc{$func} = $doc; 181 ++$func{$func}; 182 ++$important{$func} if $doc_flag =~ /i/; 183 ++$struct{$func} if $doc_flag =~ /s/; 184} 185 186sub match_funcs { 187 my ($x) = @_; 188 189 # 0=whole match, 1=proto, 2=ret type, 3=rtc, 4=name, 5=namespace, 6=local name, 7=params, 8=body 190 # 0123 3 245 5 6 64 .7 7 ,1 :8 8 ;0 191 #@fx = $x =~ /(((([\w\*:\[\]]+\s+)+)((\w+::)*(\w+))\(([\w\(\)\*:\[\],\s]*?)\))\s*\{(.+?)\n\})/sg; # version 1, requires comment removal 192 193 # 0=whole match, 1=proto, 2=ret type, 3=name, 4=namespace, 5=local name, 6=params, 7=body 194 # 0 12 2 34 4 5 53 .6 6 ,1 :7 7 ;0 195 #@fx = $x =~ m%(?:\n/\* Called by:[^\*/]*?\*/)?(\n((\w[\w\*:\[\] \t]+?)(?:[ \t]*/\*[^\*/\n]*?\*/)?\s+((\w+::)*(\w+))[ \t]*\(([\w\*:\[\],\s/.&=]*?)\))\s*(?:YYPARSE_PARAM_DECL)?(?:/\*[^\*/]*?\*/)?\s*\{(.+?)\n\})%sg; # version 2, comment tolerant 196 197 # a-z0-9*/ \n:;,.!?<>(){}\[\]\#=~- ((?:[^\*/]+[\*/]?)+) 198 # perl seg faults on: ((?:[^/]+?/?)+) 199 # (?:\s*?\n)* (?# Potential empty lines ) 200 201 if (0) { 202 my @fx = $x =~ 203 # /*() Doc string */ 204 m<(?:\n\/\*\((\w*)\)\s*([^{}]+?)\*\/)? (?# 0=doc-flag, 1=doc ) 205 (\n\n?( (?# 2=whole, 3=proto ) 206 (\w[\w\*:\[\] \t]+?) (?# 4=ret type spec) 207 (?:[ \t]*\/\*[^\*\/\n]*?\*\/)?\s+ (?# ignore /* some comment */ ) 208 ((\w+::)*(\w+)) (?# 5=full name, 6=namespace, 7=localname ) 209 [ \t]*\( (?# start parameter list ) 210 ([\w\*:\[\],\s\/.&=]*?) \) (?# 8=the parameters ) 211 )\s* (?# close 3-proto ) 212 (?:YYPARSE_PARAM_DECL)? (?# Whatever? ) 213 (?:\/\*[^\*\/]*?\*\/)? (?# Comments between proto and body ) 214 \s*\{(.+?)\n\} (?# 9=body ) 215 )>gsx; # close 2-whole ;; version 3, plaindoc and comment tolerant 216 } 217 my @fx = $x =~ 218 # /*() Doc string */ 219 m<(?:\n\/\*\(([\w-]*)\)\s*([^{}]+?)\*\/)? (?# 0=doc-flag, 1=doc ) 220 (\n\n?( (?# 2=whole, 3=proto ) 221 (\w[\w\*:\[\] \t]+?) (?# 4=ret type spec) 222 (?:[ \t]*\/\*[^\*\/\n]*?\*\/)?\s+ (?# ignore /* some comment */ ) 223 ((\w+::)*(\w+)) (?# 5=full name, 6=namespace, 7=localname ) 224 [ \t]*\(( (?# start parameter list-8 ) 225 (?:\s*[\w\*:\[\]\s\/.&]*?[\t ]+ (?# param type ) 226 \**\w+[\t \[\]=\w:.-]*,? (?# param_name[] = default assignment?, ) 227 (?:\s*\/\*[^{}]*?\*\/)? )+ (?# /* param comment */? ) 228 (?:\s*\.\.\.)? (?# more va params ... ) 229 \s*)\))\s* (?# close 8-parameters, close 3-proto ) 230 (?:YYPARSE_PARAM_DECL)? (?# Whatever? ) 231 (?:\/\*[^{}]*?\*\/)? (?# Comments between proto and body ) 232 \s*\{(.+?)\n\} (?# 9=body ) 233 )>gsx; # close 2-whole ;; version 3, plaindoc and comment tolerant 234 return @fx; 235} 236 237# Process files, grabbing what looks like function calls 238# and what looks like function definitions 239 240$0 = "reading input"; 241for $fn (@ARGV) { 242 next if $fn =~ /~$/; # Ignore backups 243 next if $fn =~ /CVS/; # Ignore files in CVS special directories 244 open F, "<$fn" or die "Can't read `$fn': $!"; 245 $x = <F>; 246 close F; 247 warn "Analyzing $fn...\n"; 248 249 #$x =~ s{/\*.*?\*/}{}gs; # strip comments 250 251 @fx = match_funcs($x); 252 253 # Constructors and destructors *** this probably needs update to account for plaindoc 254 # 0=whole match, 1=proto, 2=name, 3=namespace, 4=local name, 5=params, 6=body 255 # 0 123 3 4 42 .5 5 ,1 :6 6 ;0 256 @fy = $x =~ m%(?:\n/\* Called by:[^\*/]*?\*/)?(\n(((\w+)::(~?\4))[ \t]*\(([\w\*:\[\],\s/.&=]*?)\))\s*(?:/\*[^\*/]*?\*/)?\s*\{(.+?)\n\})%sg; # version 2, comment tolerant 257 258 while (@fx) { 259 #warn " $fx[4]()\n"; 260#WHOLE >>$fx[3]<< 261#BODY: >$fx[9]< 262 print <<DEBUG if 0; 263FX ================================================================= 264DOCFLAG: >>$fx[0]<< 265DOC: >>$fx[1]<< 266PROTO: >$fx[3]< 267RET TYPE: >$fx[4]< 268NAME: >$fx[5]< 269NAMESPACE: >$fx[6]< 270LOCALNAME: >$fx[7]< 271PARAMS: >$fx[8]< 272 273DEBUG 274 ; 275 process_func($fn, $fx[7], $fx[9]); 276 warn "fx($fx[7]) static?($fx[4])"; 277 #process_doc($fn, $fx[7], $fx[0], $fx[1], $fx[8]) if $fx[1] || $fx[4] !~ /^static /; 278 splice @fx, 0, 10; 279 } 280 281 while (@fy) { 282 #warn " $fy[4]()\n"; 283#WHOLE >>$fy[0]<< 284#BODY >>$fy[6]<< 285 print <<DEBUG if 0; 286FY ================================================================= 287WHOLE >>$fy[0]<< 288PROTO: >$fy[1]< 289NAME: >$fy[2]< 290NAMESPACE: >$fy[3]< 291LOCALNAME: >$fy[4]< 292PARAMS: >$fy[5]< 293 294DEBUG 295 ; 296 process_func($fn, $fy[4], $fy[6]); 297 splice @fy, 0, 7; 298 } 299} 300 301$callee = 'zx_scan_id'; 302$func = 'zxlex2'; 303#warn "zx_scan_id x zxlex2: `$called_by{$callee}{$func}' `$calls{$func}{$callee}'"; 304 305$0 = "generating output"; 306warn "Generating output...\n"; 307 308open F, ">function.list" or die "Cant write function.list: $!"; 309print F map qq(ZXFUNC_DEF("$_","$def{$_}[0]")\n), sort keys %def; 310close F; 311 312open F, ">file.list" or die "Cant write file.list: $!"; 313print F map qq(ZXFILE_DEF("$_")\n), sort keys %fnf; 314close F; 315 316print "$dot_header\n// Files of definition\n// =====\n"; 317 318for $k (sort keys %def) { 319 print "// $k:\t" . join(',', @{$def{$k}}) . "\n"; 320} 321 322print "\n// Called by\n// =========\n"; 323 324for $callee (sort keys %called_by) { 325 $s = ''; 326 for $k (sort keys %{$called_by{$callee}}) { 327 $s .= "$k $called_by{$callee}{$k}, "; 328 } 329 chop $s; chop $s; 330 print "// $callee:\t$s\n"; 331} 332 333### 334### Draw the call graph 335### 336 337print <<DOT; 338digraph CALL_GRAPH { 339rankdir=LR; 340ratio=compress; 341//size="10,7"; orientation=landscape; 342//size="7,10"; 343//ranksep=2; 344//nodesep=0.1; 345//page="8,11"; 346compound=true; 347concentrate=true; 348 349DOT 350 ; 351$0 = "generating dot"; 352for $fn (sort keys %fnf) { 353 ($fn2 = $fn) =~ tr[A-Za-z0-9][_]c; 354 print "subgraph cluster_$fn2 {\n label=\"$fn\";\n"; 355 for $f (sort keys %{$fnf{$fn}}) { 356 next if !$def{$f}; 357 if ($f =~ /^zxvm/) { 358 print " $f [style=filled,color=red];\n"; # [shape=box] 359 } elsif ($f =~ /^zx/) { 360 print " $f [style=filled,color=yellow];\n"; # [shape=box] 361 } elsif ($f eq 'main') { 362 print " $f [style=filled,color=red, shape=octagon];\n"; # [shape=box] 363 } else { 364 print " $f;\n"; # [shape=box] 365 } 366 for $c (sort keys %{$fnf{$fn}{$f}}) { 367 if ($fnf{$fn}{$f}{$c} > 1) { 368 print " $f -> $c [label=\"$fnf{$fn}{$f}{$c}\"];\n"; 369 } else { 370 print " $f -> $c;\n"; 371 } 372 } 373 } 374 print "}\n\n"; 375} 376 377print "}\n\n//EOF\n"; 378 379### 380### Draw function oriented call graphs (recursive by level) 381### 382 383# Generate files listing such that its not too wide 384 385sub gen_files { 386 my ($f) = @_; 387 my $fns = ''; 388 my $n = 1; 389 for $fn (@{$def{$f}}) { 390 $fns .= $fn; 391 if ($n++ % 2) { 392 $fns .= ", "; 393 } else { 394 $fns .= ",%"; 395 } 396 } 397 chop $fns; chop $fns; 398 $fns =~ s/%/\\n/g; 399 return $fns; 400} 401 402sub render_level { 403 my ($point, $level) =@_; 404 my %seen_here = (); 405 my $callee; 406 my $size = 0; # Size of the call graph 407 408 return 0 if !$level; 409 410 for $callee (sort keys %{$calls{$point}}) { 411 next if !$def{$callee}; 412 next if $seen{$callee}; 413 ++$size; 414 $seen{$callee} = 1; 415 $seen_here{$callee} = 1; 416 $files = gen_files($callee); 417 if ($level == $local_graphs{$origin}) { 418 print F "$callee [style=filled,color=yellow,label=\"$callee\\n<$files>\"];\n"; 419 } else { 420 print F "$callee [label=\"$callee\\n<$files>\"];\n"; 421 } 422 } 423 424 for $callee (sort keys %{$calls{$point}}) { 425 next if !$def{$callee}; 426 if ($level) { 427 if ($calls{$point}{$callee} > 1) { 428 print F "$point -> $callee [label=\"$calls{$point}{$callee}\"];\n"; 429 } else { 430 print F "$point -> $callee;\n"; 431 } 432 } else { 433 if ($calls{$point}{$callee} > 1) { 434 print F "$point -> $callee [style=dotted,label=\"$calls{$point}{$callee}\"];\n"; 435 } else { 436 print F "$point -> $callee [style=dotted];\n"; 437 } 438 } 439 } 440 441 --$level; 442 for $callee (sort keys %{$calls{$point}}) { 443 next if !$def{$callee}; 444 next if !$seen_here{$callee} && $seen{$callee}; 445 render_level($callee, $level); 446 } 447 return $size; 448} 449 450for $origin (sort keys %local_graphs) { 451 open F, ">ref/$origin-call.dot" or die "Can't write `ref/$origin-call.dot': $!"; 452 $files = gen_files($origin); 453 print F <<DOT; 454$dot_header 455digraph CALLS_$origin { 456rankdir=LR; 457ratio=compress; 458//size="10,7"; orientation=landscape; 459//size="7,10"; 460//ranksep=2; 461//nodesep=0.1; 462//page="8,11"; 463compound=true; 464concentrate=true; 465 466$origin [shape=octagon,style=filled,color=red,label="$origin\\n<$files>"]; 467DOT 468 ; 469 470 %seen = ($origin, 1); 471 472 # render abbreviated "callers" graph 473 474 for $cb (sort keys %{$called_by{$origin}}) { 475 next if !$def{$cb}; 476 ++$call_size{$origin}; 477 warn "ORIGIN($origin)"; 478 $seen{$cb} = 1; 479 $files = gen_files($cb); 480 print F "$cb [label=\"$cb\\n<$files>\"];\n"; 481 if ($called_by{$func}{$cb} > 1) { 482 print F "$cb -> $origin [label=\"$called_by{$origin}{$cb}\"]\n"; 483 } else { 484 print F "$cb -> $origin;\n"; 485 } 486 } 487 488 # render down stream call graph 489 490 $call_size{$origin} += render_level($origin, $local_graphs{$origin}); 491 492 print F "}\n//EOF\n"; 493 close F; 494 warn "Wrote $origin-call.dot\n"; 495} 496 497### 498### Generate function specific documentation 499### 500 501$0 = "generating func specific docu"; 502for $fn (@ARGV) { 503 next if $fn =~ /~$/; # Ignore backups 504 next if $fn =~ /CVS/; # Ignore files in CVS special directories 505 open F, "<$fn" or die "Can't read `$fn': $!"; 506 $x = <F>; 507 close F; 508 warn "Re-Analyzing $fn...\n"; 509 510 @fx = match_funcs($x); 511 while (@fx) { 512 #warn " $fx[4]()\n"; 513#WHOLE >>$fx[3]<< 514#BODY >>$fx[7]<< 515 print <<DEBUG if 0; 516FX2 ================================================================= 517NAME: >$fx[5]< 518NAMESPACE: >$fx[6]< 519LOCALNAME: >$fx[7]< 520DOCFLAG: >>$fx[0]<< 521DOC: >>$fx[1]<< 522PROTO: >$fx[3]< 523RET TYPE: >$fx[4]< 524PARAMS: >$fx[8]< 525 526DEBUG 527 ; 528 process_doc($fn, $fx[7], $fx[0], $fx[1], $fx[8]) if $fx[1] || $fx[4] !~ /^static /; 529 splice @fx, 0, 10; 530 } 531} 532 533### Annotate the source files with comments indicating where 534### each defined function is called from so that M-. (ESC-.) in 535### emacs allows you to navigate by callgraph. 536 537sub gen_called_by { 538 my ($func) = @_; 539 my $cb = ''; 540 $func =~ s/^~/D_/; 541 my $y = "\n/* Called by: "; 542 for $cb (sort keys %{$called_by{$func}}) { 543 next if !$def{$cb}; 544 if ($called_by{$func}{$cb} > 1) { 545 $y .= "$cb x$called_by{$func}{$cb}, "; 546 } else { 547 $y .= "$cb, "; 548 } 549 } 550 chop $y; chop $y; 551 return $y . " */"; 552} 553 554for $fn (sort keys %fnf) { 555 next unless $fn; 556 print STDERR "Annotating $fn ... "; 557 open F, "<$fn" or die "Can't read `$fn': $!"; 558 $x = <F>; 559 close F; 560 561 # 0=whole match, 1=proto, 2=ret type, 3=name, 4=namespace, 5=local name, 6=params, 7=body 562 # 0 12 2 34 4 5 53 .6 6 ,1 :7 7 ;0 563 $n = $x =~ s%(?:\n/\* Called by:[^\*/]*?\*/)?(\n((\w[\w\*:\[\] \t]+?)(?:[ \t]*/\*[^\*/\n]*?\*/)?\s+((\w+::)*(\w+))[ \t]*\(([\w\*:\[\],\s/.&=]*?)\))\s*(?:/\*[^\*/]*?\*/)?\s*\{(.+?)\n\})%gen_called_by($6).$1%sge; # version 2, comment tolerant 564 565 # Constructors and destructors 566 # 0=whole match, 1=proto, 2=name, 3=namespace, 4=local name, 5=params, 6=body 567 # 0 123 3 4 42 .5 5 ,1 :6 6 ;0 568 $m = $x =~ s%(?:\n/\* Called by:[^\*/]*?\*/)?(\n(((\w+)::(~?\4))[ \t]*\(([\w\*:\[\],\s/.&=]*?)\))\s*(?:/\*[^\*/]*?\*/)?\s*\{(.+?)\n\})%gen_called_by($5).$1%sge; # version 2, comment tolerant 569 570 if (($n || $m) && $write) { 571 open F, ">$fn" or die "Can't write `$fn': $!"; 572 print F $x; 573 close F; 574 warn "wrote $n changes in $fn\n"; 575 } else { 576 warn "$n changes. Nothing written.\n"; 577 } 578} 579 580### 581### Generate documentation index page 582### 583 584open M, ">ref/ref.pd" or die "Cant write ref/ref.pd: $!"; 585open F, ">ref/index.pd" or die "Cant write ref/index.pd: $!"; 586 587# Doc preamble and structs 588 589print M <<PD; 590<<if: ZXIDBOOK>> 591<<else: >>$project Reference 592################## 593<<author: Generated by call-anal.pl from comments in code.>> 594<<class: article!a4paper,10pt!!$project Ref>> 595<<version:ref: 03>> 596 597See also 598 599<<../ref-inc.pd>> 600 601<<maketoc: 1>> 602 6031 Reference 604=========== 605<<fi: >> 606 6071.1 Structures 608-------------- 609 610PD 611 ; 612print F <<PD; # Meant to generate HTML 613<<if: ZXIDBOOK>> 614<<else: >>$project Reference Index 615######################## 616<<author: Generated by call-anal.pl from comments in code>> 617<<class: article!a4paper,10pt!!$project Ref>> 618<<version:ref: 03>> 619 620See also 621 622<<../ref-inc.pd>> 623<<fi: >> 624 6251 Structures 626============ 627 628PD 629 ; 630 631for $k (sort keys %struct) { 632 print M "<<$k.pd>>\n"; 633 print F "* <<link:$k.html: $k>>\n"; 634} 635 636# Important functions index 637 638print M <<PD; 639 6401.3 Important Functions 641----------------------- 642 643PD 644 ; 645 646print F <<PD; 647 6482 Important Functions 649===================== 650 651PD 652 ; 653 654for $k (sort keys %important) { 655 if (!length $doc{$k}) { 656 warn "Important function($k) without documentation"; 657 next; 658 } 659 print M "<<$k.pd>>\n"; 660 print F "* <<link:$k.html: $k>>\n"; 661 ++$func_seen{$k}; 662} 663 664# All functions index 665 666print M <<PD; 667 6681.4 Other Functions 669------------------- 670 671PD 672 ; 673print F <<PD; 674 6753 Functions Alphabetical 676======================== 677 678PD 679 ; 680 681for $k (sort keys %func) { 682 if (!length $doc{$k}) { 683 warn "function($k) without documentation"; 684 next; 685 } 686 print F qq(<<html: <a href="$k.html">$k</a><br> >>\n); 687 if ($func_seen{$k}) { 688 warn "function($k) already seen"; 689 next; 690 } 691 print M "<<$k.pd>>\n"; 692} 693 694print M <<PD; 695<<makeindex: 1>> 696<<ignore: EOF: >> 697PD 698 ; 699print F <<PD; 700<<ignore: EOF: >> 701PD 702 ; 703 704close M; 705close F; 706 707#EOF call-anal.pl 708