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