Pm/Subdesc.pm
Copying Source is Forbidden
815 lines of code
1
package Subdesc;
2
3
#/
4
# to gather data for a given module and to output the data in HTML format<br>
5
6
# <div class="error neartiny">do not include <i>Pm/</i> or the extension when passing
7
# module names. only give the name. eg: <i>User</i> or <i>Bc_Sql</i></div>
8
9
# <table><tr><td align=left class=copyright>the following is not yet implemented:
10
# future module update:
11
# <font style='color: transparent; text-shadow: none;'>..</font>Purpose: <b>To populate a module data structure (MDS) with all of the bits and pieces of a given module</b>
12
# <font style='color: transparent; text-shadow: none;'>..</font>the MDS format will be as follows:
13
# <font style='color: transparent; text-shadow: none;'>......</font>% =>
14
# <font style='color: transparent; text-shadow: none;'>........</font>{code} = \@
15
# <font style='color: transparent; text-shadow: none;'>........</font>{name} = $
16
# <font style='color: transparent; text-shadow: none;'>........</font>{description} = $
17
# <font style='color: transparent; text-shadow: none;'>........</font>{changelog} = \@
18
# <font style='color: transparent; text-shadow: none;'>........</font>{uses} = \@ sorted
19
# <font style='color: transparent; text-shadow: none;'>........</font>{tests} = \@
20
# <font style='color: transparent; text-shadow: none;'>........</font>{exports} = \@ sorted
21
# <font style='color: transparent; text-shadow: none;'>........</font>{subs} = sorted (by subname) \@ where each element = \% =>
22
# <font style='color: transparent; text-shadow: none;'>..............</font>{name} = $
23
# <font style='color: transparent; text-shadow: none;'>..............</font>{desc} = $
24
# <font style='color: transparent; text-shadow: none;'>..............</font>{arguments} = unsorted \@ (each element formatted: "param=description");
25
# <font style='color: transparent; text-shadow: none;'>..............</font>{rvals} = unsorted \@ (each element formatted: "rval=description");
26
# <font style='color: transparent; text-shadow: none;'>..............</font>{usage} = $
27
# <font style='color: transparent; text-shadow: none;'>..............</font>{test} = $
28
# <font style='color: transparent; text-shadow: none;'>..............</font>{duplicated} = \@
29
# </td></tr></table>
30
#/
31
32
#CHLOG
33
# May 2, 2021
34
# - added change log
35
# - fixed a "return values" issue caused by heredocs (see <a href="#read_source">read_source</a> for details)
36
# - updated module's description
37
#
38
# May 4, 2021
39
# - added sub get_changelog()
40
# - many other minor bug fixes
41
# - added a button to "display_module" to show/hide the changelog
42
#
43
# May 7, 2021
44
# - immediately after the usage comment per subroutine, on a new line, we are
45
# adding a new one line comment. it'll be a hash tag followed by "test=" and
46
# a command. no spaces before and after the # and =. this comment
47
# will serve as [command/code/etc??] to execute for testing purposes.
48
# to skip testing a subroutine, put <b>exempt</b>. Go to the bottom of the
49
# <a href="#read_source">read_source</a> to see a simple example.
50
#
51
# March 15th, 2025 - ?
52
# - ongoing major updates to all code
53
#
54
#CHLOG
55
56
##########################
57
use strict;
58
use warnings;
59
use CGI::Carp qw(fatalsToBrowser);
60
use URI::Escape;
61
use Exporter;
62
use vars qw($VERSION @ISA @EXPORT_OK @EXPORT);
63
##########################
64
65
66
67
##########################
68
69
use lib "./Pm";
70
use Bc_dir;
71
72
##########################
73
74
75
76
##########################
77
$VERSION = 1.00;
78
@ISA = qw(Exporter);
79
80
@EXPORT_OK = qw(
81
get_module_data
82
get_uses
83
get_exports
84
get_description
85
get_changelog
86
get_return_values
87
get_sub_names
88
get_sub_description
89
get_sub_params
90
get_sub_usage
91
get_sub_data
92
93
make_sub_links
94
);
95
##########################
96
97
##########################
98
sub module_exists($) {
99
#*
100
# check if a module exists
101
#*
102
103
#SUBCHLOG
104
# May 7, 2021
105
# - Added this subroutine
106
#SUBCHLOG
107
my ($module) = @_; # the name of the module (do not include folder or extension; eg: Bc_sql)
108
my $rv = 0;
109
110
if (Bc_dir::file_exists("Pm/$module.pm")) { $rv = 1; }
111
112
return $rv; # 1 if it exists, or 0 if it doesn't exist
113
#usage: if (module_exists("Html2")) { ... }
114
#test=module_exists("Html2");
115
}
116
117
##########################
118
sub read_source($;$) {
119
#*
120
# reads a text file, line by line
121
# each line is plugged into an array
122
#*
123
124
#SUBCHLOG
125
# May 7, 2021
126
# - Added this subroutine
127
#SUBCHLOG
128
my ($module, $asArray) = @_; # file name to read && toggle array or array ref (optional; default = array ref)
129
130
my @lines = ();
131
132
if (module_exists($module) and open my $FH, "<", "Pm/$module.pm") {
133
# regarding heredocs and "end of subroutine" checks:
134
# we need to indent by one space any lines within a heredoc which start with a }
135
136
# Subdesc.pm's other subs check if } is the first char of a line as an end of
137
# subroutine marker. lines within heredocs which start with } will trigger
138
# "end of subroutine" prematurely. indenting these lines by one space is
139
# delicious elixir!
140
my $heredoc = 0;
141
142
while (my $line = <$FH>) {
143
chop $line; # remove \n
144
145
my $ender = "<<" . "END;";
146
147
if ($line =~ /$ender/) { $heredoc = 1; }
148
if ($heredoc) {
149
# we can do one of two things.
150
# 1. either remove the heredoc from the code
151
# or
152
# 2. prepend a single space to lines which have } as first character
153
#
154
# if we choose option 1, then our "show code" area will not have the
155
# heredoc code, and may cause confusion later.
156
# option 2 retains the heredoc code, but, any lines that would have
157
# started with a } will now be indented one space. meh, it's only
158
# aesthetics, really. later, when displaying the module's code, the
159
# indent could be removed.
160
#
161
# we will go with option 2
162
if ($line =~ /^}/) { $line =~ s/^}/ }/; }
163
if ($line =~ /^END$/) { $heredoc = 0; }
164
}
165
166
push @lines, $line;
167
}
168
169
close $FH;
170
}
171
172
if ($asArray) {
173
return @lines; # an array
174
} else {
175
return \@lines; # an array reference (default)
176
}
177
#usage: my @data = read_source($filename);
178
#test=Html::display_debug_one("read_source(\"Html2\")", read_source("Html2"));
179
}
180
181
##########################
182
sub get_module_data($;$) {
183
#*
184
# builds the Module Data Structure
185
#*
186
187
#SUBCHLOG
188
# March 12, 2025
189
# - removed asHash from parameters list
190
#SUBCHLOG
191
my ($module) = @_; # the name of the module to read
192
my %rv;
193
194
$rv{code} = read_source($module);
195
$rv{name} = get_name($rv{code});
196
$rv{uses} = get_uses($rv{code});
197
$rv{exports} = get_exports($rv{code});
198
$rv{description} = get_description($rv{code});
199
$rv{changelog} = get_changelog($rv{code});
200
$rv{tests} = get_tests($rv{code});
201
202
my @subs = get_sub_names($rv{code}, 1);
203
my @subdata;
204
foreach my $subname (@subs) {
205
my $subref = get_sub_data($rv{code}, $subname);
206
push @subdata, $subref;
207
}
208
if (@subdata) { $rv{subs} = \@subdata; }
209
210
return \%rv; # a hash reference (default)
211
#usage: my %module_data = get_module_data("Html2");
212
#test=get_module_data("Html2");
213
}
214
215
##########################
216
sub get_sub_data($$;$) {
217
#*
218
# gets data for a given single subroutine in the given code
219
#*
220
221
#SUBCHLOG
222
# March 12, 2025
223
# - added asHash to parameters
224
#SUBCHLOG
225
my ($code, $subname, $asHash) = @_; # the module's code && the name of the subroutine && return a hash, or hash reference (default = hash reference)
226
my %rv;
227
228
if (ref $code eq "ARRAY") {
229
$rv{code} = get_sub_code($code, $subname);
230
231
$rv{name} = get_sub_name($rv{code});
232
$rv{description} = get_sub_description($rv{code});
233
$rv{arguments} = get_sub_params($rv{code});
234
$rv{rvals} = get_sub_return_values($rv{code});
235
$rv{usage} = get_sub_usage($rv{code});
236
$rv{changelog} = get_sub_changelog($rv{code});
237
$rv{test} = get_sub_testcmd($rv{code});
238
}
239
240
if ($asHash) {
241
return %rv; # a hash
242
} else {
243
return \%rv; # a hash reference
244
}
245
#usage: $subdata = get_sub_data("Html2", "tag");
246
#test=get_sub_data("Html2", "tag");
247
}
248
249
##########################
250
sub get_sub_code($;$) {
251
#*
252
# gets the code for a given subroutine
253
#*
254
my ($code, $subname, $asArray) = @_; # the module's code && the name of the subroutine && return as array or array reference (default = array reference)
255
my @rv = ();
256
257
my $record = 0;
258
foreach my $line (@$code) {
259
if ($line =~ /^sub $subname/) { $record = 1; }
260
if ($record) { push @rv, $line; }
261
if ($record and $line =~ /^}/) { $record = 0; last; }
262
}
263
264
if ($asArray) {
265
return @rv; # an array
266
} else {
267
return \@rv; # an array reference (default)
268
}
269
}
270
271
##########################
272
sub get_sub_name($;$) {
273
#*
274
# gets a subroutine's name from the given subroutine code
275
#*
276
my ($code, $asRef) = @_; # subroutine's code && as scalar, or reference to a scalar
277
my $rv = "(unnamed!?)";
278
279
# the first line of $code ought to contain the name of the subroutine
280
# we will assume it does.
281
282
if (ref $code eq "ARRAY") {
283
$rv = $code->[0];
284
$rv =~ s/^sub //;
285
$rv =~ s/\((.)*//;
286
}
287
288
if ($asRef) {
289
return \$rv; # a reference to a scalar
290
} else {
291
return $rv; # a scalar
292
}
293
}
294
295
##########################
296
sub get_sub_changelog($;$) {
297
#*
298
# gets a given subroutine's change log
299
#*
300
301
#SUBCHLOG
302
# March 12, 2025
303
# - added asArray to parameters
304
#SUBCHLOG
305
my ($code, $subname, $asArray) = @_; # subroutine's code && subroutine's name && returns an array or reference (default = array ref)
306
my @rv = ();
307
my $found = 0;
308
309
foreach my $line (@$code) {
310
my $t = $line;
311
if ($t =~ /^ *\#SUBCHLOG/) { $found++; }
312
if ($found == 1) {
313
if ($t =~ s/\#//) {
314
$t =~ s/^ *SUBCHLOG//;
315
if ($t) { push(@rv, $t); }
316
}
317
}
318
}
319
320
if ($asArray) {
321
return @rv; # an array (can be empty)
322
} else {
323
return \@rv; # an array reference (default; referenced array can be empty)
324
}
325
#usage: my $subchlog = get_sub_changelog($mds->{subs}, "tag");
326
#test=get_changelog("Html2");
327
}
328
329
##########################
330
sub get_name($;$) {
331
#*
332
# gets the name of a module
333
#*
334
my ($code, $asRef) = @_; # a module's code && return scalar, or scalar reference (default = scalar)
335
my $rv = "";
336
337
foreach my $line (@$code) {
338
my $tmp = $line;
339
if ($tmp =~ s/^package //) {
340
$rv = $tmp;
341
$rv =~ s/;//;
342
last;
343
}
344
}
345
346
if ($asRef) {
347
return \$rv; # a scalar reference
348
} else {
349
return $rv; # a scalar
350
}
351
}
352
353
##########################
354
sub get_description($;$) {
355
#*
356
# gets the description for a module
357
#*
358
359
#SUBCHLOG
360
# May 5, 2021
361
# - added subroutine change log
362
# - tweaked the shit outta this subroutine!
363
# March 12, 2025
364
# - added $asArray paramater
365
#SUBCHLOG
366
367
#SUBBUGS
368
# - May 5, 2021: if module's description is a one liner, this returns nothing!
369
# - resolved (May 6, in the wee hours)
370
#SUBBUGS
371
my ($code, $asArray) = @_; # the module's code && return as an array, or array reference (default = array reference)
372
373
my $found = 0;
374
my @rv;
375
376
foreach my $line (@$code) {
377
my $tmp = $line;
378
if ($tmp =~ s"^#/"") {
379
if (not $found)
380
{ $found = 1; } else
381
{ $found = 0; }
382
}
383
384
if ($found) {
385
$tmp =~ s/^# //;
386
if ($tmp) { push @rv, $tmp; }
387
}
388
}
389
390
if ($asArray) {
391
return @rv; # an array (can be empty)
392
} else {
393
return \@rv; # an array reference (default; referenced array can be empty)
394
}
395
#usage: my $desc = get_description($mds->{code}, "Html2");
396
#test=(none);
397
}
398
399
##########################
400
sub get_changelog($;$) {
401
#*
402
# gets the change log for a module
403
# always returns an array reference
404
#*
405
406
#SUBCHLOG
407
# March 12, 2025
408
# - added asArray to parameters
409
#SUBCHLOG
410
my ($code, $asArray) = @_; # a module's code && return as array or array reference (default = reference)
411
412
my $found = 0;
413
my @log;
414
415
foreach my $line (@$code) {
416
my $t = $line;
417
if ($t =~ /^\#CHLOG/) { $found++; }
418
if ($found == 1) {
419
if ($t =~ s/\#//) {
420
$t =~ s/^CHLOG//;
421
if ($t) { push(@log, $t); }
422
}
423
}
424
}
425
426
if ($asArray) {
427
return @log; # an array (can be empty)
428
} else {
429
return \@log; # an array reference (default; referenced array can be empty)
430
}
431
#usage: my $chlog = get_changelog("Html2");
432
#test=get_changelog("Html2");
433
}
434
435
##########################
436
sub get_uses($;$) {
437
#*
438
# gets all "use" statements from a given module
439
# always returns an array reference
440
#*
441
442
#SUBCHLOG
443
# March 12, 2025
444
# - added asArray to parameters
445
#SUBCHLOG
446
my ($code, $asArray) = @_; # a module's code && return as array or array reference (default = array ref)
447
my @uses = ();
448
449
foreach my $line (@$code) {
450
my $t = $line;
451
my $useCheck = "use ";
452
if ($t =~ /^$useCheck/i) {
453
# is the module being "use"d one found in Pm?
454
my $um = $t; # um = module being used (eg: strict)
455
$um =~ s/^$useCheck//i;
456
$um =~ s/^qw\(//;
457
$um =~ s/[\)|;| ].*$//;
458
if ($um !~ /lib/ and $um !~ /Crypt::/ and $um !~ /LWP::/ and $um !~ /HTML/ and $um !~ /File::/ and $um !~ /DBI/ and $um !~ /CGI/ and $um !~ /strict/ and $um !~ /warnings/ and $um !~ /URI::Escape/ and $um !~ /Exporter/ and $um !~ /vars/) {
459
push @uses, $um;
460
}
461
}
462
}
463
464
if ($asArray) {
465
return @uses; # an array (can be empty)
466
} else {
467
return \@uses; # an array reference (referenced array can be empty)
468
}
469
#usage: my $uses = get_uses("Html2");
470
#test=(none);
471
}
472
473
##########################
474
sub get_exports($;$) {
475
#*
476
# gets all exports found in @EXPORTS = qw( ... )
477
# always returns an array reference
478
#*
479
480
#SUBCHLOG
481
# March 12, 2025
482
# - added asArray to parameters
483
#SUBCHLOG
484
my ($code, $asArray) = @_; # code && return as array or array reference (default = array ref)
485
my @rv = ();
486
my $exports_found = 0;
487
488
foreach my $line (@$code) {
489
my $t = $line;
490
if ($t =~ /^our \@EXPORT \= qw\(/i or
491
$t =~ /^\@EXPORT \= qw\(/) {
492
$exports_found = 1;
493
} else {
494
if ($exports_found and
495
$t =~ /\);$/) {
496
$exports_found = 0;
497
} else {
498
if ($exports_found) {
499
if ($t) {
500
$t =~ s/ //g;
501
push @rv, $t;
502
}
503
}
504
}
505
}
506
}
507
508
if ($asArray) {
509
return @rv; # an array (can be empty);
510
} else {
511
return \@rv; # an array reference (can be empty)
512
}
513
#usage: my $exp = get_module_exports("HTML");
514
#test=get_module_exports("Html2");
515
}
516
517
##########################
518
sub get_tests($;$) {
519
#*
520
# gets a list of tests for a given module
521
#*
522
my ($code, $asArray) = @_; # the module's code && return as array or array reference (default = array ref)
523
my @rv;
524
525
foreach my $line (@$code) {
526
my $tmp = $line;
527
if ($tmp =~ s/ \#test=//) {
528
if ($tmp !~ /\(none\)\;/i) { push @rv, $tmp; }
529
}
530
}
531
532
if ($asArray) {
533
return @rv; # an array (can be empty)
534
} else {
535
return \@rv; # an array reference (default; referenced array can be empty)
536
}
537
#usage: $output .= get_module_tests($mds->{subs});
538
#test=(none);
539
}
540
541
##########################
542
sub get_sub_names($;$) {
543
#*
544
# returns a list of all subroutine names for a specified module
545
#*
546
547
#SUBCHLOG
548
# March 12, 2025
549
# - added asArray to parameters
550
#SUBCHLOG
551
my ($code, $asArray) = @_; # a module's code && returns an array or an array reference (default = array ref)
552
my @names = ();
553
554
if (ref $code eq "ARRAY") {
555
foreach my $line (@$code) {
556
my $t = $line;
557
if ($t =~ s/^sub //) {
558
$t =~ s/\(.*//;
559
push @names, $t;
560
}
561
}
562
}
563
564
if ($asArray) {
565
return @names; # an array (can be empty)
566
} else {
567
return \@names; # an array reference (can reference an empty array)
568
}
569
#usage: my @subnames = get_sub_names("Html2");
570
#test=get_sub_names("Html2");
571
}
572
573
##########################
574
sub get_sub_description($$;$) {
575
#*
576
# gets a given subroutine's description
577
#*
578
579
#SUBCHLOG
580
# March 12, 2025
581
# - added asArray to parameters
582
#SUBCHLOG
583
my ($code, $subname, $asArray) = @_; # a subroutine's code && subroutine's name && returns an array or reference (default = array ref)
584
my $subfound = 0;
585
my $descfound = 0;
586
587
my @desc = ();
588
foreach my $line (@$code) {
589
my $t = $line;
590
$t =~ s/( )*//; # remove leading spaces
591
if ($t =~ /^\#\*/) {
592
$descfound++;
593
} else {
594
if ($descfound eq 1) {
595
if ($t =~ s/^( )*\#//) {
596
# remove leading spaces and the # sign and one space
597
$t =~ s/^ //;
598
if ($t) {
599
$t =~ /^(\s*)/;
600
my $numspaces = length($1);
601
if ($numspaces) {
602
$t =~ s/^(\s*)//;
603
}
604
605
push @desc, $t;
606
}
607
}
608
}
609
}
610
}
611
612
if ($asArray) {
613
return @desc; # an array
614
} else {
615
return \@desc; # an array reference
616
}
617
#usage: my @desc = get_sub_description($module_name, $sub_name);
618
#test=get_sub_description("Html2", "tag");
619
}
620
621
##########################
622
sub get_sub_params($;$) {
623
#*
624
# gets a list of subroutine parameters from a specified module (no need to include .pm) and subroutine
625
# each list element should look like: "$uid;a uid"
626
#*
627
628
#SUBCHLOG
629
# March 12, 2025
630
# - added asArray to parameters
631
#SUBCHLOG
632
my ($code, $asArray) = @_; # a subroutine's code && return an array or an array reference
633
my @rv;
634
my $found = 0;
635
636
foreach my $line (@$code) {
637
my $t = $line;
638
# $line is formatted as:
639
# my ($var1, $var2, $var3) = @_; # var1 desc && var2 desc && var3 desc
640
if ($t =~ s/\) = \@_;//) {
641
$t =~ s/my \(//;
642
$t =~ s/^ *//;
643
644
# now that we have the arguments and descriptions in a line, split at #
645
my @data = split(" # ", $t); # a two piece list: vars and descriptions
646
my @params = split(", ", $data[0]); # the vars list
647
my @desc = split(" && ", $data[1]); # the descriptions list
648
649
for (my $i = 0; $i < @params; $i++) {
650
if ($params[$i] and $desc[$i]) {
651
push @rv, "$params[$i]-----$desc[$i]";
652
}
653
}
654
655
last;
656
}
657
}
658
659
if ($asArray) {
660
return @rv; # an array
661
} else {
662
return \@rv; # an array reference
663
}
664
#usage: my $subparams = get_sub_params($module_name, $sub_name);
665
#test=get_sub_params("Html2", "tag");
666
}
667
668
##########################
669
sub get_sub_return_values($$;$) {
670
#*
671
# this function will return a list of
672
# a given subroutine's return values
673
#*
674
675
#SUBCHLOG
676
# March 12, 2025
677
# - added asArray to parameters
678
#SUBCHLOG
679
my ($code, $subname, $asArray) = @_; # an array of subroutines (eg: $mds->{subs}) && name of the subroutine to list return values for && return an array, or an array reference (default = array ref)
680
my @rValues;
681
my $foundsubr = 0;
682
683
foreach my $line (@$code) {
684
my $t = $line;
685
my $s = "su" . "b ";
686
my $r = "ret" . "urn ";
687
# if $r comes after a pound sign, then $r is within a comment and thus, will be ignored
688
# first, locate if and where the sign's at
689
# then locate $r
690
my $pindex = index($t, "#"); # the string "index" of the # sign
691
my $rindex = index($t, $r); # the string "index" of the word "return"
692
693
# so now...if $rindex < $pindex (and both are >= 0), then we found a return statement!
694
if (
695
$rindex >= 0 and
696
$pindex >= 0 and
697
$rindex < $pindex
698
) {
699
# $t should now look like: "$rval # a scalar"
700
# first, let's split this in two (rval and description)
701
$t =~ s/^ +return//;
702
my @splitup = split(" # ", $t); # should create two elements. one contains the value to be returned, and the other contains a description of the rvalue
703
if (@splitup == 2) {
704
$splitup[0] =~ s/^ *//; # remove leading spaces
705
$splitup[0] =~ s/\;$//; # remove the end of line marker, and any trailing spaces
706
}
707
708
# now, push a reference to this array into @rValues
709
push @rValues, \@splitup;
710
}
711
else {
712
# we end up here, because $pindex or $rindex is -1, or $rindex >= $pindex
713
# if $pindex is -1 then insert a msg sayin the description doesn't exist for this rval
714
if ($rindex > -1 and $pindex < 0) {
715
my @rValFixed = ($t, "<table border=0 cellpadding=0 cellspacing=0><tr><td class=error nowrap> rval description missing </td></tr></table>");
716
push @rValues, \@rValFixed;
717
}
718
}
719
}
720
721
if ($asArray) {
722
return @rValues; # an array (can be empty)
723
} else {
724
return \@rValues; # an array reference (default; referenced array can be empty)
725
}
726
#usage: my @subrvals = get_return_values($mds->{subs}, $sub_name);
727
#test=get_sub_return_values("Html2", "tag");
728
}
729
730
##########################
731
sub get_sub_usage($$;$) {
732
#*
733
# gets the usage of a specified subroutine from a specified module
734
# add two = signs to a usage: statement to insert a line break
735
#*
736
737
#SUBCHLOG
738
# March 12, 2025
739
# - added asRef to parameters
740
#SUBCHLOG
741
my ($code, $subname, $asRef) = @_; # an array of subroutines (eg: $mds->{subs}) && name of the subroutine to read && return a scalar, or a scalar reference (default = scalar)
742
my $found = 0;
743
my $rv;
744
745
foreach my $line (@$code) {
746
my $t = $line;
747
if ($t =~ s/ \Q#usage:\E //) {
748
$t =~ s/\=\=/<br>/g;
749
$rv = $t;
750
last;
751
}
752
}
753
754
if ($asRef) {
755
return \$rv; # a scalar reference
756
} else {
757
return $rv; # a scalar
758
}
759
#usage: my $usage = get_sub_usage($module_name, $sub_name);
760
#test=get_sub_usage("Html2", "tag");
761
}
762
763
##########################
764
sub get_sub_testcmd($$;$) {
765
#*
766
# gets the "test" comment of a specified subroutine from
767
# a specified module (no need to include .pm)
768
# this could probably just return a scalar, but, for future-proofing
769
# purposes, we'll return an array (or a ref to an array)
770
#*
771
772
#SUBCHLOG
773
# March 12, 2025
774
# - added asArray to parameters
775
#SUBCHLOG
776
my ($code, $subname, $asArray) = @_; # the module's code && name of the subroutine to read
777
my @rv = ();
778
779
my $found = 0;
780
781
foreach my $line (@$code) {
782
my $t = $line;
783
if ($t =~ s/ *\#test=//) {
784
push @rv, $t;
785
last;
786
}
787
}
788
789
if ($asArray) {
790
return @rv; # an array (can be empty)
791
} else {
792
return \@rv; # an array reference (default; can be empty)
793
}
794
#usage: $output .= get_sub_testcmd($module_name, $sub_name);
795
#test=get_sub_testcmd("Html2", "tag");
796
}
797
798
##########################
799
##########################
800
##########################
801
##########################
802
##########################
803
##########################
804
805
sub _tests() {
806
my $rv = "";
807
my $test = "Subdesc";
808
809
my $mds = get_module_data($test);
810
$rv .= Html::display_debug_scalar("Module Data Sheet", $mds);
811
812
return $rv; # a scalar
813
}
814
815
1;