File Coverage

blib/lib/Perinci/Gen/ForModule.pm
Criterion Covered Total %
statement 59 65 90.7
branch 8 14 57.1
condition 6 13 46.1
subroutine 10 10 100.0
pod 1 1 100.0
total 84 103 81.5


line stmt bran cond sub pod time code
1             package Perinci::Gen::ForModule;
2              
3             our $DATE = '2016-06-14'; # DATE
4             our $VERSION = '0.09'; # VERSION
5              
6 1     1   14494 use 5.010001;
  1         2  
7 1     1   4 use strict;
  1         2  
  1         18  
8 1     1   4 use warnings;
  1         1  
  1         28  
9 1     1   948 use Log::Any::IfLOG '$log';
  1         13  
  1         6  
10              
11 1     1   723 use SHARYANTO::Array::Util qw(match_array_or_regex);
  1         12306  
  1         102  
12 1     1   611 use Package::MoreUtil qw(package_exists list_package_contents);
  1         907  
  1         78  
13              
14 1     1   6 use Exporter qw(import);
  1         3  
  1         295  
15             our @EXPORT_OK = qw(gen_meta_for_module);
16              
17             our %SPEC;
18              
19             $SPEC{gen_meta_for_module} = {
20             v => 1.1,
21             summary => 'Generate metadata for a module',
22             description => <<'_',
23              
24             This function can be used to automatically generate Rinci metadata for a
25             "traditional" Perl module which do not have any. Currently, only a plain and
26             generic package and function metadata are generated.
27              
28             The resulting metadata will be put in %::SPEC. Functions that already
29             have metadata in the %SPEC will be skipped. The metadata will have
30             C property set to true, C set to C, and C
31             set to C<{args => ["any" => {schema=>'any', pos=>0, greedy=>1}]}>. In the
32             future, function's arguments (and other properties) will be parsed from POD (and
33             other indicators).
34              
35             _
36             args => {
37             module => {
38             schema => 'str*',
39             summary => 'The module name',
40             },
41             load => {
42             schema => ['bool*' => {default=>1}],
43             summary => 'Whether to load the module using require()',
44             },
45             include_subs => {
46             schema => ['any' => { # XXX or regex
47             of => [['array*'=>{of=>'str*'}], 'str*'], # 2nd should be regex*
48             }],
49             summary => 'If specified, only include these subs',
50             },
51             exclude_subs => {
52             schema => ['any' => { # XXX or regex
53             of => [['array*'=>{of=>'str*'}], 'str*'], # 2nd should be regex*
54             default => '^_',
55             }],
56             summary => 'If specified, exclude these subs',
57             description => <<'_',
58              
59             By default, exclude private subroutines (subroutines which have _ prefix in
60             their names).
61              
62             _
63             },
64             },
65             };
66             sub gen_meta_for_module {
67 1     1 1 7 my %args = @_;
68              
69 1         2 my $inc = $args{include_subs};
70 1   33     10 my $exc = $args{exclude_subs} // qr/^_/;
71              
72             # XXX schema
73             my $module = $args{module}
74 1 50       3 or return [400, "Please specify module"];
75 1   50     6 my $load = $args{load} // 1;
76              
77 1 50       3 if ($load) {
78 1         2 eval {
79 1         1 my $modulep = $module; $modulep =~ s!::!/!g;
  1         4  
80 1         222 require "$modulep.pm";
81             };
82 1         4 my $eval_err = $@;
83             #return [500, "Can't load module $module: $eval_err"] if $eval_err;
84             # ignore the error and try to load it anyway
85             }
86 1 50       5 return [500, "Package $module does not exist"]
87             unless package_exists($module);
88              
89 1         21 my $note;
90             {
91 1     1   8 no strict 'vars'; # for $VERSION
  1         1  
  1         78  
  1         1  
92 1   50     89 $note = "This metadata is automatically generated by ".
93             __PACKAGE__." version ".($VERSION//"?")." on ".localtime();
94             }
95              
96 1         2 my $metas;
97             {
98 1     1   6 no strict 'refs';
  1         2  
  1         400  
  1         1  
99 1         2 $metas = \%{"$module\::SPEC"};
  1         4  
100             }
101              
102 1 50       5 if (keys %$metas) {
103 0         0 $log->info("Not creating metadata for package $module: ".
104             "already defined");
105 0         0 return [304, "Not modified"];
106             }
107              
108             # generate package metadata
109 1         4 $metas->{":package"} = {
110             v => 1.1,
111             summary => $module,
112             description => $note,
113             };
114              
115 1         4 my %content = list_package_contents($module);
116              
117             # generate subroutine metadatas
118 1         83 for my $sub (sort grep {ref($content{$_}) eq 'CODE'} keys %content) {
  4         12  
119 3         17 $log->tracef("Adding meta for subroutine %s ...", $sub);
120 3 50 33     30 if (defined($inc) && !match_array_or_regex($sub, $inc)) {
121 0         0 $log->info("Not creating metadata for sub $module\::$sub: ".
122             "doesn't match include_subs");
123 0         0 next;
124             }
125 3 100 66     10 if (defined($exc) && match_array_or_regex($sub, $exc)) {
126 1         20 $log->info("Not creating metadata for sub $module\::$sub: ".
127             "matches exclude_subs");
128 1         2 next;
129             }
130 2 50       18 if ($metas->{$sub}) {
131 0         0 $log->info("Not creating metadata for sub $module\::$sub: ".
132             "already defined");
133 0         0 next;
134             }
135              
136 2         11 my $meta = {
137             v => 1.1,
138             summary => $sub,
139             description => $note,
140             result_naked => 1,
141             args_as => 'array',
142             args => {
143             args => {
144             schema => ['array*' => {of=>'any'}],
145             summary => 'Arguments',
146             pos => 0,
147             greedy => 1,
148             },
149             },
150             };
151 2         3 $metas->{$sub} = $meta;
152             }
153              
154 1         5 [200, "OK", $metas];
155             }
156              
157             1;
158             # ABSTRACT: Generate metadata for a module
159              
160             __END__