Pm/Autodoc.pm
Copying Source is Forbidden
811 lines of code
1
use strict;
2
use warnings;
3
4
package Autodoc;
5
6
#/
7
# a module to read the source code of any module and, essentially, summarize it
8
# in a tidy data structure (an MDS, Module Data Structure)<br>
9
10
# \% =>
11
# {link} = $ = for debug.pl link to module
12
# {linkname} = $ = for debug.pl link to module
13
# {name} = $ = module's name
14
# {source} = \@[x] = $ = module's actual source code
15
# {description} = \@[x] = $ = description
16
# {changelog} = \@[x] = $ = change log
17
# {uses} = \@[x] = $ = a sorted list of used Pm/ modules
18
# {exports} = \@[x] = $ = a list of exported subs & vars
19
# {subs} = \@[x] = \% =>
20
# {source} = \@[x] = $ = subroutine's actual source code
21
# {name} = $ = name of subroutine
22
# {usage} = $ = the "usage" clause
23
# {test} = $ = "test" command (used in eval())
24
# {description} = \@[x] = $ = subroutine's description
25
# {rvals} = \% =>
26
# {value} = $ = the return value
27
# {description} = $ = description of return value
28
# {arguments} = \% =>
29
# {name} = $ = name of argument
30
# {description} = $ = description of argument
31
# {optional} = $ = whether argument is optional or not
32
# {prototype} = \% =>
33
# {required} = \@[x] = $ = a list of required arguments
34
# {optional} = \@[x] = $ = a list of optional arguments
35
#/
36
37
#CHLOG
38
# CHANGELOG
39
# =========
40
# - May 10, 2021
41
# - Added module
42
#
43
# - May 11, 2021
44
# - Added, and updated many/all subroutines
45
#
46
# - May 12, 2021
47
# - Added AUTODOC-NAME, -LINK, and -ICON to MDS and created related "get" subroutines
48
#
49
#CHLOG
50
51
#AUTODOC-NAME=Autodoc
52
#AUTODOC-LINK=autodoc
53
54
use CGI::Carp qw(fatalsToBrowser);
55
use Exporter;
56
use vars qw($VERSION @ISA @EXPORT_OK @EXPORT);
57
use CGI;
58
59
$VERSION = 1.00;
60
@ISA = qw(Exporter);
61
62
##########################
63
64
#use statements here
65
use lib "/var/www/html/Pm";
66
#use Bc_dir qw(file_exists files);
67
require Bc_dir;
68
69
##########################
70
71
my $TABLE_BORDER = 0;
72
my $DEBUG = 0;
73
74
##########################
75
sub module_exists($) {
76
#*
77
# check if a module exists
78
# use this only when generating an MDS
79
#*
80
#SUBCHLOG
81
# May 7, 2021
82
# - Added this subroutine
83
#SUBCHLOG
84
my ($module) = @_; # name of module (do not include dir or ext)
85
my $rv = 0;
86
87
if (file_exists("Pm/$module.pm")) { $rv = 1; }
88
89
return $rv; # 1 if it exists, or 0 if it doesn't exist
90
#usage: $module_exists = module_exists("Html2");
91
#test=module_exists("Html2");
92
}
93
94
###############################
95
sub read_module($) {
96
#*
97
# reads the module's source into an array
98
# use this only when generating an MDS
99
#*
100
my ($module) = @_; # a module's name
101
my @lines = ();
102
103
if (module_exists($module) and open my $FH, "<", "Pm/$module.pm") {
104
# regarding heredocs and "end of subroutine" checks:
105
# we need to indent by one space any lines within a heredoc which start with a }
106
107
# Subdesc.pm's other subs check if } is the first char of a line as an end of
108
# subroutine marker. lines within heredocs which start with } will trigger
109
# "end of subroutine" prematurely. indenting these lines by one space is
110
# delicious elixir!
111
my $heredoc = 0;
112
113
while (my $line = <$FH>) {
114
chop $line; # remove \n
115
116
my $ender = "<<" . "END;";
117
118
if ($line =~ /$ender/) { $heredoc = 1; }
119
if ($heredoc) {
120
# we can do one of two things.
121
# 1. either remove the heredoc from the code
122
# or
123
# 2. prepend a single space to lines which have } as first character
124
#
125
# if we choose option 1, then our "show code" area will not have the
126
# heredoc code, and may cause confusion later.
127
# option 2 retains the heredoc code, but, any lines that would have
128
# started with a } will now be indented one space. meh, it's only
129
# aesthetics, really. later, when displaying the module's code, the
130
# indent could be removed.
131
if ($line =~ /^END$/) { $heredoc = 0; }
132
if ($line =~ /^}/) { $line =~ s/^}/ }/; }
133
}
134
135
# convert < to <
136
$line =~ s/</</g;
137
push @lines, $line;
138
}
139
140
close $FH;
141
}
142
143
return \@lines; # always returns a reference to an array
144
#usage: my $source_code = read_module($filename);
145
#test=Html::display_debug_scalar("read_module(\"Html2\")", Autodoc::read_module("Html2"));
146
}
147
148
###############################
149
sub module_get_description($) {
150
#*
151
# finds a description from a given source
152
# each line of the description is added to
153
# an array.
154
# use this only when generating an MDS
155
#*
156
my ($source) = @_; # source code of a module
157
my $rv = "";
158
159
my $found = 0;
160
my @desc;
161
162
if (ref $source eq "ARRAY") {
163
my @source = @$source;
164
foreach my $line (@source) {
165
if (not $found) {
166
if ($line =~ /^\#\//) { $found = 1; }
167
}
168
else {
169
if ($line !~ /^\#\//) {
170
if ($line) {
171
$line =~ s/^# //;
172
if ($line) {
173
$line =~ s/ / /g;
174
push @desc, $line;
175
}
176
}
177
} else {
178
last;
179
}
180
}
181
}
182
183
if ($found) {
184
$rv = \@desc;
185
} else {
186
push @desc, "!no description";
187
}
188
}
189
else {
190
push @desc, "!source is not an array!";
191
}
192
193
return $rv; # always returns a reference to an array
194
#usage: my $description = module_get_description($source);
195
#test=Html::display_debug_scalar("module_get_description(\"Html2\")", Autodoc::module_get_description("Html2"));
196
}
197
198
###############################
199
sub module_get_changelog($) {
200
#*
201
# finds the changelog from a given source
202
# each line of the changelog is added to
203
# an array. an array reference is returned.
204
# use this only when generating an MDS
205
#*
206
my ($source) = @_; # source code of a module
207
my $rv = "";
208
209
my $found = 0;
210
my @chlog;
211
212
if (ref $source eq "ARRAY") {
213
my @source = @$source;
214
foreach my $line (@source) {
215
if (not $found) {
216
if ($line =~ /^\#CHLOG/) { $found = 1; }
217
}
218
else {
219
if ($line !~ /^\#CHLOG/) {
220
if ($line) {
221
$line =~ s/^# *//;
222
if ($line) { push @chlog, $line; }
223
}
224
} else {
225
last;
226
}
227
}
228
}
229
230
if ($found) {
231
$rv = \@chlog;
232
} else {
233
push @chlog, "!no changes log";
234
}
235
}
236
else {
237
push @chlog, "!source is not an array!";
238
}
239
240
return $rv; # always returns a reference to an array
241
#usage: my $changelog = module_get_changelog($source);
242
#test=Html::display_debug_scalar("module_get_changelog(\"Html2\")", Autodoc::module_get_changelog("Html2"));
243
}
244
245
###############################
246
sub module_get_uses($) {
247
#*
248
# finds the use statements from a given source
249
# each module declared is added to an array.
250
# use this only when generating an MDS
251
#*
252
my ($source) = @_; # source code of a module
253
my $rv;
254
my @files = Bc_dir::files("Pm/", "pm");
255
my @uses;
256
257
if (ref $source eq "ARRAY") {
258
my @source = @$source;
259
foreach my $line (@source) {
260
if ($line =~ s/^use //) {
261
$line =~ s/ .*//;
262
$line =~ s/;.*//;
263
foreach my $file (@files) {
264
if ($file eq $line . ".pm") { push @uses, $line; }
265
}
266
}
267
}
268
}
269
else {
270
push @uses, "none";
271
}
272
273
$rv = \@uses;
274
275
return $rv; # always returns a reference to an array
276
#usage: my $uses = module_get_uses($source);
277
#test=Html::display_debug_scalar("module_get_uses(\"Html2\")", Autodoc::module_get_uses("Html2"));
278
}
279
280
###############################
281
sub module_get_exports($) {
282
#*
283
# finds the exports from a given source
284
# each export is added to an array.
285
# an array reference is returned.
286
# use this only when generating an MDS
287
#*
288
my ($source) = @_; # source code of a module
289
my $rv = "";
290
291
my $found = 0;
292
my @exports;
293
294
if (ref $source eq "ARRAY") {
295
# two loops. doing simple and similar jobs.
296
# coulda been one loop, but, meh. this way
297
# is clearer and less prone to errors. also,
298
# it's not like this is a slow process.
299
300
# first, look for "our \@EXPORT = qw\(" and add all the exports listed
301
# to the export list
302
my @source = @$source;
303
foreach my $line (@source) {
304
if (not $found) {
305
if ($line =~ /^our \@EXPORT = qw\(/) { $found = 1; }
306
}
307
else {
308
if ($line !~ /\);$/) {
309
if ($line) {
310
$line =~ s/^ *//;
311
if ($line) {
312
if ($line =~ / /) {
313
@exports = split(" ", $line);
314
last;
315
} else {
316
push @exports, $line;
317
}
318
}
319
}
320
}
321
else {
322
last;
323
}
324
}
325
}
326
327
# now, look for "push \@EXPORT, \""
328
foreach my $line (@source) {
329
if ($line =~ s/^push \@EXPORT, \"//) {
330
$found++;
331
$line =~ s/\";//;
332
push @exports, $line;
333
}
334
}
335
336
if ($found) {
337
$rv = \@exports;
338
}
339
}
340
else {
341
push @exports, "!source is not an array!";
342
}
343
344
$rv = \@exports;
345
346
return $rv; # always returns a reference to an array
347
#usage: my $exports = module_get_exports($source);
348
#test=Html::display_debug_scalar("module_get_exports(\"Html2\")", Autodoc::module_get_exports("Html2"));
349
}
350
351
###############################
352
sub module_get_link($) {
353
#*
354
# to get the "AUTODOC-LINK" from a module
355
# the name of this function sucks.
356
#*
357
my ($source) = @_; # source code of a module
358
my $rv = "";
359
360
if (ref $source eq "ARRAY") {
361
if (@$source) {
362
my @source = @$source;
363
foreach my $line (@source) {
364
my $tmp = $line;
365
if ($tmp =~ s/^#AUTODOC-LINK=//) {
366
$rv = $tmp;
367
}
368
}
369
}
370
}
371
372
return $rv; # always returns a scalar
373
#usage: my $link = module_get_link($source);
374
#test=Html::display_debug_scalar("module_get_link(\"Html2\")", Autodoc::module_get_link("Html2"));
375
}
376
377
###############################
378
sub module_get_linkname($) {
379
#*
380
# to get the "AUTODOC-NAME" from a module
381
# the name of this function sucks.
382
#*
383
my ($source) = @_; # source code of a module
384
my $rv = "";
385
386
if (ref $source eq "ARRAY") {
387
if (@$source) {
388
my @source = @$source;
389
foreach my $line (@source) {
390
my $tmp = $line;
391
if ($tmp =~ s/^#AUTODOC-NAME=//) {
392
$rv = $tmp;
393
}
394
}
395
}
396
}
397
398
return $rv; # always returns a scalar
399
#usage: my $link = module_get_linkname($source);
400
#test=none
401
}
402
403
###############################
404
sub module_get_linkicon($) {
405
#*
406
# to get the "AUTODOC-NAME" from a module
407
# the name of this function sucks.
408
#*
409
my ($source) = @_; # source code of a module
410
my $rv = "";
411
412
if (ref $source eq "ARRAY") {
413
if (@$source) {
414
my @source = @$source;
415
foreach my $line (@source) {
416
my $tmp = $line;
417
if ($tmp =~ s/^#AUTODOC-ICON=//) {
418
$rv = $tmp;
419
}
420
}
421
}
422
}
423
424
return $rv; # always returns a scalar
425
#usage: my $link = module_get_linkicon($source);
426
#test=none
427
}
428
429
###############################
430
sub module_get_sub_source($$) {
431
#*
432
# gets a subroutine's source code
433
# use this only when generating an SDS
434
#*
435
my ($source, $subname) = @_; # source code of a module
436
my $rv = "";
437
438
my $found = 0;
439
my @subsource;
440
my $sds;
441
442
if (ref $source eq "ARRAY") {
443
my @source = @$source;
444
if (@source) {
445
foreach my $line (@source) {
446
my $temp = $line;
447
if ($temp =~ /^sub $subname/) { $found = 1; }
448
if ($found) {
449
push @subsource, $line;
450
if ($temp =~ /^}/) { $found = 0; last; }
451
}
452
}
453
}
454
else {
455
$rv = "source array is empty!";
456
}
457
}
458
else {
459
push @subsource, "!source is not an array!";
460
}
461
462
$rv = \@subsource;
463
464
return $rv; # always returns a reference to an array
465
#usage: my $changelog = module_get_sub_source($source, "tag");
466
}
467
468
###############################
469
sub module_get_sub_usage($) {
470
#*
471
# gets a subroutine's usage comment
472
# use this only when generating an SDS
473
#*
474
my ($source) = @_; # source code of a subroutine
475
my $rv;
476
477
if (ref $source eq "ARRAY") {
478
if (@$source) {
479
foreach my $line (@$source) {
480
my $u = $line;
481
if ($u =~ s/ *#usage: //) { $rv = $u; }
482
}
483
}
484
else {
485
$rv = "!no code!";
486
}
487
}
488
else {
489
$rv = "!source is not an array!";
490
}
491
492
return $rv; # always returns a scalar
493
#usage: my $usage = module_get_sub_usage($subsource);
494
}
495
496
###############################
497
sub module_get_sub_test($) {
498
#*
499
# gets a subroutine's test comment
500
# use this only when generating an SDS
501
#*
502
my ($source) = @_; # source code of a subroutine
503
my $rv = "!no test command found";
504
505
if (ref $source eq "ARRAY") {
506
if (@$source) {
507
foreach my $line (@$source) {
508
my $t = $line;
509
if ($t =~ s/ *#test=//) { $rv = $t; }
510
}
511
}
512
else {
513
$rv = "!no code!";
514
}
515
}
516
else {
517
$rv = "!source is not an array!";
518
}
519
520
return $rv; # always returns a scalar
521
#usage: my $test = module_get_sub_test($subsource);
522
}
523
524
###############################
525
sub module_get_sub_prototype($) {
526
#*
527
# gets a subroutine's prototyped arguments
528
# use this only when generating an SDS
529
#*
530
my ($source) = @_; # source code of a subroutine
531
my $rv = "!no test command found";
532
533
if (ref $source eq "ARRAY") {
534
if (@$source) {
535
foreach my $line (@$source) {
536
my $t = $line;
537
if ($t =~ s/^sub .*\(//) {
538
$t =~ s/\).*//;
539
my @proto = split(";", $t);
540
my %prototype;
541
my @req = split("", $proto[0]);
542
my @opt = split("", $proto[1]);
543
$prototype{required} = \@req;
544
$prototype{optional} = \@opt;
545
$prototype{declaration} = $t;
546
$rv = \%prototype;
547
}
548
}
549
}
550
else {
551
$rv = "!no code!";
552
}
553
}
554
else {
555
$rv = "!source is not an array!";
556
}
557
558
return $rv; # always returns a reference to a hash
559
#usage: my $argproto = module_get_sub_prototype($subsource);
560
}
561
562
###############################
563
sub module_get_sub_arguments($) {
564
#*
565
# gets a subroutine's arguments
566
# use this only when generating an SDS
567
#*
568
my ($source) = @_; # source code of a subroutine
569
my $rv = ();
570
571
if (ref $source eq "ARRAY") {
572
if (@$source) {
573
my $proto = module_get_sub_prototype($source);
574
575
foreach my $line (@$source) {
576
my $argstr = $line;
577
578
if ($argstr =~ /\) = \@_; # /) {
579
$argstr =~ s/ *my \(//;
580
$argstr =~ s/\) = \@_; # /#/;
581
$argstr =~ s/ && /&&/g;
582
583
my @args_descs = split("#", $argstr);
584
my @names = split(", ", $args_descs[0]);
585
my @descs = split("&&", $args_descs[1]);
586
587
my $i = 0;
588
foreach my $name (@names) {
589
my %argument;
590
$argument{name} = $name;
591
$argument{description} = $descs[$i];
592
my $ref = $proto->{required};
593
if (ref $ref eq "ARRAY") {
594
my @arr = @$ref;
595
if ($i >= @arr) { $argument{optional} = 1; } else { $argument{optional} = 0; }
596
}
597
598
push @$rv, \%argument;
599
600
$i++;
601
}
602
}
603
}
604
}
605
}
606
607
return $rv; # always returns a reference to a hash
608
#usage: my $arguments = module_get_sub_arguments($subsource);
609
}
610
611
###############################
612
sub module_get_sub_rvals($) {
613
#*
614
# gets a subroutine's return values
615
# use this only when generating an SDS
616
#*
617
my ($source) = @_; # source code of a subroutine
618
my $rv = ();
619
620
if (ref $source eq "ARRAY") {
621
my @source = @$source;
622
if (@source) {
623
foreach my $line (@source) {
624
my $rval = $line;
625
if ($rval =~ s/^ *return //) {
626
$rval =~ s/; # /#/;
627
my @rval = split("#", $rval);
628
629
my %rval;
630
$rval{value} = $rval[0];
631
$rval[1] =~ s/</</g;
632
$rval{description} = $rval[1];
633
634
push @$rv, \%rval;
635
}
636
}
637
}
638
}
639
640
return $rv; # always returns a reference to a hash
641
#usage: my $rvals = module_get_sub_rvals($subsource);
642
}
643
644
###############################
645
sub module_get_sub_description($) {
646
#*
647
# gets a subroutine's arguments
648
# use this only when generating an SDS
649
#*
650
my ($source) = @_; # source code of a subroutine
651
my $rv = ();
652
653
if (ref $source eq "ARRAY") {
654
my $found = 0;
655
if (@$source) {
656
foreach my $line (@$source) {
657
my $d = $line;
658
659
if ($d =~ /#\*/) {
660
if ($found)
661
{ last; } else
662
{ $found = 1; }
663
}
664
elsif ($found) {
665
$d =~ s/^ *# //;
666
push @$rv, $d;
667
}
668
}
669
}
670
}
671
672
return $rv; # always returns a reference to an array
673
#usage: my $description = module_get_sub_description($subsource);
674
}
675
676
###############################
677
sub module_get_subs($) {
678
#*
679
# builds an SDS for each subroutine,
680
# and puts em in a list
681
#*
682
my ($source) = @_; # source code of a module
683
my $rv;
684
685
if (ref $source eq "ARRAY") {
686
my @source = @$source;
687
if (@source) {
688
my @subnames;
689
foreach my $line (@source) {
690
my $s = $line;
691
if ($s =~ s/^sub //) {
692
$s =~ s/\(.*//;
693
if ($s ne "_tests") { push @subnames, $s; }
694
}
695
}
696
697
698
foreach my $sub (@subnames) {
699
my $subsource = module_get_sub_source($source, $sub);
700
if ($subsource) {
701
my %sds;
702
$sds{source} = $subsource;
703
$sds{name} = $sub;
704
$sds{usage} = module_get_sub_usage($subsource);
705
$sds{test} = module_get_sub_test($subsource);
706
$sds{description} = module_get_sub_description($subsource);
707
$sds{rvals} = module_get_sub_rvals($subsource);
708
$sds{prototype} = module_get_sub_prototype($subsource);
709
if ($sds{prototype}) { $sds{arguments} = module_get_sub_arguments($subsource); }
710
711
my $exports = module_get_exports($source);
712
foreach my $export (@$exports) {
713
if ($export eq $sub) { $sds{exported} = 1; } else { $sds{exported} = 0; }
714
}
715
716
push @$rv, \%sds;
717
}
718
}
719
}
720
}
721
722
return $rv; # always returns a reference to an array
723
#usage: my $exports = module_get_subs($source);
724
#test=Html::display_debug_scalar("module_get_subs(\"Html2\")", Autodoc::module_get_subs("Html2"));
725
}
726
727
###############################
728
push @EXPORT_OK, "load_module";
729
push @EXPORT, "load_module";
730
sub load_module($) {
731
#*
732
# to load a module into an MDS
733
# !do not include folder (Pm/)
734
# !do not include extension (.pm)
735
#*
736
my ($module) = @_; # name of module
737
my $rv;
738
739
if (module_exists($module)) {
740
my $source = read_module($module);
741
my $description = module_get_description($source);
742
my $changelog = module_get_changelog($source);
743
my $uses = module_get_uses($source);
744
my $exports = module_get_exports($source);
745
my $subs = module_get_subs($source);
746
my $link = module_get_link($source);
747
my $linkname = module_get_linkname($source);
748
my $linkicon = module_get_linkicon($source);
749
750
$rv->{link} = $link;
751
$rv->{linkname} = $linkname;
752
$rv->{linkicon} = $linkicon;
753
$rv->{name} = $module;
754
$rv->{source} = $source;
755
$rv->{description} = $description;
756
$rv->{changelog} = $changelog;
757
$rv->{uses} = $uses;
758
$rv->{exports} = $exports;
759
$rv->{subs} = $subs;
760
}
761
762
return $rv; # always returns a reference to an MDS
763
#usage: my $mds = load_module("Html2");
764
#test=Html::display_debug_scalar("load_module(\"Html2\")", Autodoc::load_module("Html2"));
765
}
766
767
###############################
768
###############################
769
###############################
770
###############################
771
###############################
772
###############################
773
###############################
774
###############################
775
###############################
776
###############################
777
###############################
778
###############################
779
###############################
780
###############################
781
###############################
782
###############################
783
###############################
784
###############################
785
###############################
786
###############################
787
###############################
788
###############################
789
###############################
790
###############################
791
###############################
792
###############################
793
###############################
794
###############################
795
###############################
796
###############################
797
798
###############################
799
sub _tests(;$) {
800
#*
801
# to test <i>Pm::Autodoc</i>
802
#*
803
my ($extended) = @_; # show extended data (optional)
804
my $module = "Html";
805
my $rv = Html::display_debug_scalar("MDS for $module.pm", load_module($module));
806
807
return $rv; # a scalar
808
#usage: print _tests();
809
}
810
811
1;