File Coverage

blib/lib/Module/Generate.pm
Criterion Covered Total %
statement 342 356 96.0
branch 104 118 88.1
condition 32 55 58.1
subroutine 53 55 96.3
pod 30 33 90.9
total 561 617 90.9


line stmt bran cond sub pod time code
1             package Module::Generate;
2              
3 6     6   419491 use 5.006;
  6         65  
4 6     6   35 use strict;
  6         11  
  6         160  
5 6     6   30 use warnings;
  6         10  
  6         247  
6              
7 6     6   44 use Cwd qw/abs_path/;
  6         12  
  6         322  
8 6     6   6381 use Perl::Tidy;
  6         1814658  
  6         644  
9 6     6   80 use Data::Dumper;
  6         14  
  6         297  
10 6     6   3128 use Module::Starter;
  6         16506  
  6         41  
11             $Data::Dumper::Deparse = 1;
12             our $VERSION = '0.26';
13             our %CLASS;
14             our $SUB_INDEX = 1;
15              
16             sub start {
17 2 100   2 1 1493 return ref $_[0] ? $_[0] : bless {}, $_[0];
18             }
19              
20             sub dist {
21 4     4 1 5468 $CLASS{DIST} = $_[1];
22 4 100       27 return ref $_[0] ? $_[0] : bless {}, $_[0];
23             }
24              
25             sub class {
26 29     29 1 52544 my ($self, $class) = @_;
27 29         166 $CLASS{CURRENT} = $CLASS{$class} = {
28             NAME => $class
29             };
30 29 100       208 return ref $self ? $self : bless {}, $self;
31             }
32              
33             sub lib {
34 9     9 1 16997 $CLASS{LIB} = $_[1];
35 9 100       66 return ref $_[0] ? $_[0] : bless {}, $_[0];
36             }
37              
38             sub tlib {
39 2     2 1 8 $CLASS{TLIB} = $_[1];
40 2 50       12 return ref $_[0] ? $_[0] : bless {}, $_[0];
41             }
42              
43             sub author {
44 7     7 1 2563 $CLASS{AUTHOR} = $_[1];
45 7 100       39 return ref $_[0] ? $_[0] : bless {}, $_[0];
46             }
47              
48             sub email {
49 7     7 1 2571 $CLASS{EMAIL} = $_[1];
50 7 100       38 return ref $_[0] ? $_[0] : bless {}, $_[0];
51             }
52              
53             sub version {
54 7     7 1 2491 $CLASS{VERSION} = $_[1];
55 7 100       74 return ref $_[0] ? $_[0] : bless {}, $_[0];
56             }
57              
58             sub synopsis {
59 1     1 1 5 $CLASS{CURRENT}{SYNOPSIS} = $_[1];
60 1         3 return $_[0];
61             }
62              
63             sub abstract {
64 5     5 1 15 $CLASS{CURRENT}{ABSTRACT} = $_[1];
65 5         19 return $_[0];
66             }
67              
68             sub use {
69 5     5 1 13 my $self = shift;
70 5   100     33 $CLASS{CURRENT}{USE} ||= [];
71 5         16 push @{ $CLASS{CURRENT}{USE} }, @_;
  5         14  
72 5         18 return $self;
73             }
74              
75             sub base {
76 3     3 1 14 my $self = shift;
77 3   100     31 $CLASS{CURRENT}{BASE} ||= [];
78 3         7 push @{ $CLASS{CURRENT}{BASE} }, @_;
  3         11  
79 3         11 return $self;
80             }
81              
82             sub parent {
83 3     3 1 9 my $self = shift;
84 3   100     20 $CLASS{CURRENT}{PARENT} ||= [];
85 3         6 push @{ $CLASS{CURRENT}{PARENT} }, @_;
  3         13  
86 3         13 return $self;
87             }
88              
89             sub require {
90 3     3 1 10 my $self = shift;
91 3   100     19 $CLASS{CURRENT}{REQUIRE} ||= [];
92 3         7 push @{ $CLASS{CURRENT}{REQUIRE} }, @_;
  3         11  
93 3         15 return $self;
94             }
95              
96             sub our {
97 5     5 1 13 my $self = shift;
98 5   100     46 $CLASS{CURRENT}{GLOBAL} ||= [];
99 5         10 push @{ $CLASS{CURRENT}{GLOBAL} }, @_;
  5         19  
100 5         32 return $self;
101             }
102              
103             sub begin {
104 4     4 1 11 $CLASS{CURRENT}{BEGIN} = $_[1];
105 4         15 return $_[0];
106             }
107              
108             sub unitcheck {
109 1     1 1 28 $CLASS{CURRENT}{UNITCHECK} = $_[1];
110 1         8 return $_[0];
111             }
112              
113             sub check {
114 1     1 1 5 $CLASS{CURRENT}{CHECK} = $_[1];
115 1         4 return $_[0];
116             }
117              
118             sub init {
119 1     1 1 4 $CLASS{CURRENT}{INIT} = $_[1];
120 1         4 return $_[0];
121             }
122              
123             sub end {
124 1     1 1 3 $CLASS{CURRENT}{END} = $_[1];
125 1         4 return $_[0];
126             }
127              
128             sub new {
129 6     6 1 17 my ($self, $sub) = @_;
130             $CLASS{CURRENT}{SUBS}{CURRENT} = $CLASS{CURRENT}{SUBS}{new} = {
131 6         77 INDEX => $SUB_INDEX++,
132             POD => "Instantiate a new $CLASS{CURRENT}{NAME} object.",
133             EXAMPLE => "$CLASS{CURRENT}{NAME}\-\>new"
134             };
135 6 100       781 $CLASS{CURRENT}{SUBS}{CURRENT}{CODE} = $sub ? $sub : eval "sub {
136             my (\$cls, \%args) = (shift, scalar \@_ == 1 ? \%{\$_[0]} : \@_);
137             bless \\%args, \$cls;
138             }";
139             $CLASS{CURRENT}{SUBS}{CURRENT}{TEST} = [
140 6         69 ['ok', sprintf 'my $obj = %s->new', $CLASS{CURRENT}{NAME}],
141             ['isa_ok', '$obj', qq|'$CLASS{CURRENT}{NAME}'|],
142             ];
143 6         29 return $self;
144             }
145              
146             sub accessor {
147 6     6 1 19 my ($self, $sub, $code) = @_;
148 6         60 $CLASS{CURRENT}{SUBS}{CURRENT} = $CLASS{CURRENT}{SUBS}{$sub} = {
149             INDEX => $SUB_INDEX++,
150             ACCESSOR => 1,
151             POD => "get or set ${sub}.",
152             EXAMPLE => "\$obj->${sub}\;\n\n\t\$obj->${sub}(\$value)\;"
153             };
154 6 100       578 $CLASS{CURRENT}{SUBS}{CURRENT}{CODE} = $code ? $code : eval "sub {
155             my (\$self, \$value) = \@_;
156             if (defined \$value) {
157             \$self->{$sub} = \$value;
158             }
159             return \$self->{$sub}
160             }";
161             $CLASS{CURRENT}{SUBS}{CURRENT}{TEST} = [
162 6         57 ['can_ok', qq|\$obj|, qq|'$sub'|],
163             ['is', qq|\$obj->$sub|, 'undef'],
164             ['is', qq|\$obj->$sub('test')|, qq|'test'|],
165             ['deep',qq|\$obj->$sub({ a => 'b' })|, qq|{ a => 'b' }|],
166             ['deep',qq|\$obj->$sub|, qq|{ a => 'b' }|]
167             ];
168 6         24 return $self;
169             }
170              
171             sub sub {
172 7     7 1 18 my ($self, $sub) = @_;
173 7         25 $CLASS{CURRENT}{SUBS}{CURRENT} = $CLASS{CURRENT}{SUBS}{$sub} = {
174             INDEX => $SUB_INDEX++
175             };
176             $CLASS{CURRENT}{SUBS}{CURRENT}{TEST} = [
177 7         26 ['can_ok', qq|\$obj|, qq|'$sub'|],
178             ];
179 7         52 return $self;
180             }
181              
182             sub macro {
183 6     6 1 24 my ($self, $name, $code) = @_;
184 6 100       47 $code = ref $code ? Dumper $code : $code;
185 6         8751 $code =~ s/\$VAR1 = //;
186 6         32 $code =~ s/sub\s*//;
187 6         59 $code =~ s/{\s*\n*|\s*\n*};$//g;
188 6         26 $CLASS{MACRO}{$name} = $code;
189 6         31 return $self;
190             }
191              
192             sub keyword {
193 2 50 50 2 1 25 my ($self, $name, %keyword) = (shift, shift, (! ref $_[0] ? @_ : ref $_[0] eq 'HASH' ? %{$_[0]} : (
  0 50       0  
    100          
194             CODE => $_[0],
195             KEYWORDS => $_[1] || [],
196             ($_[2] ? ( POD_TITLE => $_[2] ) : ())
197             )));
198 2         5 push @{$keyword{KEYWORDS}}, $name;
  2         5  
199 2         5 $CLASS{KEYWORD}{$name} = \%keyword;
200 2         4 my $MACROS = join '|', map { quotemeta($_) } keys %{$CLASS{MACRO}};
  0         0  
  2         8  
201             {
202 6     6   73399 no strict 'refs';
  6         19  
  6         16442  
  2         3  
203 2         4 my $cls = ref $self;
204 2         14 *{"${cls}::$name"} = sub {
205 3     3   7 my ($self, $value) = (shift, _stringify_struct($MACROS, @_));
206 3         15 $CLASS{CURRENT}{SUBS}{CURRENT} = $CLASS{CURRENT}{SUBS}{$SUB_INDEX} = {
207             INDEX => $SUB_INDEX++,
208             KEYWORD => $name,
209             $name => $value
210             };
211 3         7 for (qw/POD EXAMPLE/) {
212 6 100       28 if ($CLASS{KEYWORD}{$name}{"POD_$_"}) {
213 4         10 $CLASS{CURRENT}{SUBS}{CURRENT}{$_} = $CLASS{KEYWORD}{$name}{"POD_$_"};
214 4         16 $CLASS{CURRENT}{SUBS}{CURRENT}{$_} =~ s/\$keyword/$value/g;
215             }
216             }
217 3         18 return $self;
218 2         20 };
219 2         5 for my $add (@{$keyword{KEYWORDS}}) {
  2         3  
220 4 100       13 next if $add eq $name;
221 2         8 *{"${cls}::$add"} = sub {
222 2     2   8 my ($self, $code) = (shift, _stringify_struct($MACROS, @_));
223 2         5 $CLASS{CURRENT}{SUBS}{CURRENT}{$add} = $code;
224 2         9 return $self;
225 2         7 };
226             }
227             }
228 2         14 return $self;
229             }
230              
231             sub code {
232 8     8 1 20 my ($self, $code) = @_;
233 8         18 $CLASS{CURRENT}{SUBS}{CURRENT}{CODE} = $code;
234 8         24 return $self;
235             }
236              
237             sub no_code {
238 0     0 0 0 my ($self, $code) = @_;
239 0         0 $CLASS{CURRENT}{SUBS}{CURRENT}{NO_CODE} = $code;
240 0         0 return $self;
241             }
242              
243             sub pod {
244 5     5 1 9 my ($self, $pod) = @_;
245 5         11 $CLASS{CURRENT}{SUBS}{CURRENT}{POD} = $pod;
246 5         23 return $self;
247             }
248              
249             sub example {
250 4     4 1 11 my ($self, $pod) = @_;
251 4         10 $CLASS{CURRENT}{SUBS}{CURRENT}{EXAMPLE} = $pod;
252 4         12 return $self;
253             }
254              
255             sub class_tests {
256 1     1 0 3 my ($self, @tests) = @_;
257 1         2 push @{$CLASS{CURRENT}{CLASS_TESTS}}, @tests;
  1         3  
258 1         3 return $self;
259             }
260              
261             sub test {
262 4     4 1 10 my ($self, @tests) = @_;
263 4         7 push @{$CLASS{CURRENT}{SUBS}{CURRENT}{TEST}}, @tests;
  4         11  
264 4         15 return $self;
265             }
266              
267             sub clear_tests {
268 0     0 0 0 my ($self) = @_;
269 0         0 $CLASS{CURRENT}{SUBS}{CURRENT}{TEST} = [];
270 0         0 return $self;
271             }
272              
273             sub generate {
274 8     8 1 2354 my ($self, %args) = @_;
275              
276 8         36 my @classes = sort grep { $_ !~ m/^(LIB|TLIB|AUTHOR|EMAIL|VERSION|DIST|CURRENT|MACRO|KEYWORD)$/ } keys %CLASS;
  46         196  
277              
278 8   100     42 my $lib = $CLASS{LIB} || ".";
279 8         19 my $tlib = $CLASS{TLIB};
280 8 100       32 if ($CLASS{DIST}) {
281 2         5 my $distro = delete $CLASS{DIST};
282             Module::Starter->create_distro(
283             dir => $lib . "/$distro",
284             distro => $distro,
285             builder => 'ExtUtils::MakeMaker',
286             modules => [@classes],
287             author => 'LNATION',
288             email => 'email@lnation.org',
289 2         12 %{$args{DIST}}
  2         31  
290             );
291 1         59632 $tlib = "$lib/$distro/t";
292 1         13 $lib = "$lib/$distro/lib";
293             }
294              
295 7         46 for my $class (@classes) {
296             my $cls = _perl_tidy(
297             sprintf(
298             qq{package %s; use strict; use warnings;%s\n%s\n%s\n%s\n\n1;\n\n__END__%s },
299             $class,
300             _build_use($CLASS{$class}),
301             _build_global($CLASS{$class}{GLOBAL}),
302             _build_phase($CLASS{$class}),
303             _build_subs($CLASS{$class}),
304 8         66 _build_pod($class, $CLASS{$class})
305             )
306             );
307              
308 8         73 (my $path = $class) =~ s/\:\:/\//g;
309 8         82 my $file = sprintf "%s/%s.pm", $lib, $path;
310 8         111 _make_path($file);
311 8 100       943 open(my $fh, '>', $file) or die "Cannot open file to write $!";
312 7         146 print $fh $cls;
313 7         483 close $fh;
314 7 100       81 if ($tlib) {
315             my $test_file = _perl_tidy(
316             sprintf(
317             qq{use Test::More; use strict; use warnings;%sdone_testing();},
318 4         45 _build_tests($CLASS{$class})
319             )
320             );
321 4         27 $class =~ s/\:\:/-/g;
322 4         39 my $file = sprintf "%s/%s.t", $tlib, $class;
323 4         25 _make_path($file);
324 4 50       545 open(my $fh, '>', $file) or die "Cannot open file to write $!";
325 4         184 print $fh $test_file;
326 4         288 close $fh;
327             }
328             }
329             }
330              
331              
332             sub _make_path {
333 14     14   4167 my $path = abs_path();
334 14         155 for (split '/', $_[0]) {
335 64 100       322 next if $_ =~ m/\.pm|\.t/;
336 52         164 $path .= "/$_";
337 52         196 $path =~ m/(.*)/;
338 52 100       1095 if (! -d $1) {
339 5 100       433 mkdir $1 or die "Cannot open file for writing $!";
340             }
341             }
342 13         64 return $path;
343             }
344              
345             sub _build_use {
346 8     8   16 my @codes;
347 8 100       52 if ($_[0]->{USE}) {
348 3         6 my @use = @{$_[0]->{USE}};
  3         14  
349 3         13 while (@use) {
350 3         7 my $mod = shift @use;
351 3 50 33     14 $mod .= ' ' . shift @use if ($use[0] && $use[0] =~ s/^\[(.*)\]$/$1/sg);
352 3         15 push @codes, "use $mod;";
353             }
354             }
355 8 100       43 push @codes, sprintf("use base qw/%s/;", join " ", @{$_[0]->{BASE}}) if $_[0]->{BASE};
  1         8  
356 8 100       68 push @codes, sprintf("use base qw/%s/;", join " ", @{$_[0]->{PARENT}}) if $_[0]->{PARENT};
  1         9  
357 8 100       38 push @codes, map { "use $_;" } @{$_[0]->{REQUIRE}} if $_[0]->{REQUIRE};
  1         4  
  1         4  
358 8         59 return join "\n", @codes;
359             }
360              
361             sub _build_global {
362 8     8   21 my @codes = map { "our $_;" } @{$_[0]};
  3         23  
  8         56  
363 8   100     54 $CLASS{VERSION} ||= 0.01;
364 8         49 unshift @codes, "our \$VERSION = $CLASS{VERSION};";
365 8         44 return join "\n", @codes;
366             }
367              
368             sub _build_phase {
369 9     9   2010 my $phases = shift;
370 9         21 my @codes;
371 9         25 for (qw/BEGIN UNITCHECK CHECK INIT END/) {
372 45 100       113 if ($phases->{$_}) {
373 4 100       60 my $code = ref $phases->{$_} ? Dumper $phases->{$_} : $phases->{$_};
374 4         4315 $code =~ s/\$VAR1 = //;
375 4         30 $code =~ s/^\s*sub\s*//;
376 4         89 $code =~ s/\s*\n*\s*package Module\:\:Generate\;|use warnings\;|use strict\;//g;
377 4         26 $code =~ s/};$/}/;
378 4         22 $code = sprintf "%s %s;", 'BEGIN', $code;
379 4         18 push @codes, $code;
380             }
381             }
382 9         65 return join "\n", @codes;
383             }
384              
385             sub _stringify_struct {
386 5     5   11 my ($MACROS, @struct) = @_;
387 5 50       13 if ($#struct > 0) {
388 0         0 return '(' . (join ", ", map { _stringify_struct($MACROS, $_) } @struct) . ')';
  0         0  
389             }
390 5 50       12 $struct[0] = ref $struct[0] ? Dumper $struct[0] : $struct[0];
391 5 50       11 return unless defined $struct[0];
392 5         9 $struct[0] =~ s/\$VAR1 = //;
393 5         11 $struct[0] =~ s/\s*\n*\s*package Module\:\:Generate\;|use warnings\;|use strict\;//g;
394 5         9 $struct[0] =~ s/{\s*\n*/{/;
395 5         7 $struct[0] =~ s/};$/}/;
396 5         23 $struct[0] =~ s/\&($MACROS)/$CLASS{MACRO}{$1}/g;
397 5         14 return $struct[0];
398             }
399              
400             sub _build_subs {
401 10     10   2597 my ($class) = @_;
402 10         20 my @codes;
403 10         35 delete $class->{SUBS}{CURRENT};
404              
405 10         21 my $MACROS = join '|', map { quotemeta($_) } keys %{$CLASS{MACRO}};
  5         22  
  10         43  
406 10         26 for my $sub (sort {
407             $class->{SUBS}{$a}{INDEX} <=> $class->{SUBS}{$b}{INDEX}
408 16         40 } keys %{$class->{SUBS}}) {
  10         64  
409 19 50       86 next if $class->{SUBS}{$sub}{NO_CODE};
410 19         30 my $code;
411 19 100       80 if ($class->{SUBS}{$sub}{KEYWORD}) {
    100          
412 3         6 my $meta = $class->{SUBS}{$sub};
413 3         7 my $keyword = $CLASS{KEYWORD}{$class->{SUBS}{$sub}{KEYWORD}};
414             $meta->{CODE} = _stringify_struct(
415             $MACROS,
416 0         0 ((ref($meta->{CODE}) || "") eq "ARRAY" ? @{$meta->{CODE}} : $meta->{CODE})
417 3 0 0     9 ) if defined $meta->{CODE};
    50          
418 3         14 $code = $keyword->{CODE}->($meta, $keyword->{KEYWORDS});
419             } elsif ($class->{SUBS}{$sub}{CODE}) {
420 15 100       96 $code = ref $class->{SUBS}{$sub}{CODE} ? Dumper $class->{SUBS}{$sub}{CODE} : $class->{SUBS}{$sub}{CODE};
421 15         25427 $code =~ s/\$VAR1 = //;
422 15         85 $code =~ s/^\s*sub\s*//;
423 15         1225 $code =~ s/\s*\n*\s*package Module\:\:Generate\;|use warnings\;|use strict\;//g;
424 15         76 $code =~ s/{\s*\n*/{/;
425 15         67 $code =~ s/};$/}/;
426 15 100       150 $code =~ s/\&($MACROS)/$CLASS{MACRO}{$1}/g if $MACROS;
427 15         79 $code = sprintf "sub %s %s", $sub, $code;
428             } else {
429 1         6 $code = sprintf "sub %s {\n\n\n}", $sub;
430             }
431 19         114 push @codes, $code;
432             }
433 10         117 return join "\n", @codes;
434             }
435              
436             sub _build_pod {
437 9     9   2547 my ($class, $definition) = @_;
438 6     6   78 my $d = do { no strict 'refs'; \*{"Module::Generate::DATA"} };
  6         16  
  6         9180  
  9         20  
  9         27  
  9         70  
439 9         136 seek $d, 0, 0;
440 9         6276 my $content = join '', <$d>;
441 9         1523 $content =~ s/^.*\n__DATA__\n/\n/s;
442 9         96 $content =~ s/\n__END__\n.*$/\n/s;
443              
444 9         72 my %sections = (
445             subs => [],
446             accessor => []
447             );
448              
449 9         26 for my $sub (sort {
450             $definition->{SUBS}{$a}{INDEX} <=> $definition->{SUBS}{$b}{INDEX}
451 16         48 } keys %{$definition->{SUBS}}) {
  9         67  
452 18 100       76 my $spod = $definition->{SUBS}{$sub}{POD} ? $definition->{SUBS}{$sub}{POD} : "";
453 18 100       109 if ($definition->{SUBS}{$sub}{KEYWORD}) {
    100          
454 3         21 my $name = $definition->{SUBS}{$sub}{$definition->{SUBS}{$sub}{KEYWORD}};
455 3         23 push @{$sections{$definition->{SUBS}{$sub}{KEYWORD}}}, $definition->{SUBS}{$sub}{EXAMPLE}
456             ? sprintf("=head2 %s\n\n%s\n\n\t%s",
457             $name, $spod, $definition->{SUBS}{$sub}{EXAMPLE})
458 3 100       5 : sprintf("=head2 %s\n\n%s", $name, $spod);
459             } elsif ($definition->{SUBS}{$sub}{ACCESSOR}) {
460 4         20 push @{$sections{accessor}}, $definition->{SUBS}{$sub}{EXAMPLE}
461             ? sprintf("=head2 %s\n\n%s\n\n\t%s",
462             $sub, $spod, $definition->{SUBS}{$sub}{EXAMPLE})
463 4 100       5 : sprintf("=head2 %s\n\n%s", $sub, $spod);
464             } else {
465 11         83 push @{$sections{subs}}, $definition->{SUBS}{$sub}{EXAMPLE}
466             ? sprintf("=head2 %s\n\n%s\n\n\t%s",
467             $sub, $spod, $definition->{SUBS}{$sub}{EXAMPLE})
468 11 100       19 : sprintf("=head2 %s\n\n%s", $sub, $spod);
469             }
470             }
471              
472 9 100       24 if (scalar @{$sections{accessor}}) {
  9         39  
473 2         5 unshift @{$sections{accessor}}, "=head1 ACCESSORS";
  2         7  
474             }
475              
476 9 100       17 if (scalar @{$sections{subs}}) {
  9         54  
477 6         12 unshift @{$sections{subs}}, "=head1 SUBROUTINES/METHODS";
  6         21  
478             }
479              
480 9         20 for (keys %{$CLASS{KEYWORD}}) {
  9         49  
481 4   66     7 unshift @{$sections{$_}}, sprintf "=head1 %s", $CLASS{KEYWORD}{$_}{POD_TITLE} || uc($_);
  4         32  
482             }
483              
484 9         23 my @subs = map { @{ $sections{$_} }} 'subs', 'accessor', sort keys %{$CLASS{KEYWORD}};
  22         40  
  22         69  
  9         31  
485              
486 9         36 my $lcname = lc($class);
487 9         33 (my $safename = $class) =~ s/\:\:/-/g;
488 9 100       52 $CLASS{EMAIL} =~ s/\@/ at / if $CLASS{EMAIL};
489             my %params = (
490             lcname => $lcname,
491             safename => $safename,
492             name => $class,
493             abstract => ($definition->{ABSTRACT} ? $definition->{ABSTRACT} : sprintf('The great new %s!', $class)),
494             version => $definition->{VERSION} || '0.01',
495             subs => join("\n\n", @subs),
496             synopsis => ($definition->{SYNOPSIS}
497             ? $definition->{SYNOPSIS}
498             : sprintf("Quick summary of what the module does.\n\tuse %s;\n\n\tmy \$foo = %s->new();\n\n\t...", $class, $class)
499             ),
500             author => $CLASS{AUTHOR} || "AUTHOR",
501 9 100 100     259 email => $CLASS{EMAIL} || "EMAIL"
    100 100        
      100        
502             );
503              
504 9         58 my $reg = join "|", keys %params;
505              
506 9         714 $content =~ s/\{\{($reg)\}\}/$params{$1}/g;
507              
508 9         138 return $content;
509             }
510              
511             sub _perl_tidy {
512 13     13   4431 my $source = shift;
513 13         48 my $dest_string;
514             my $stderr_string;
515 13         0 my $errorfile_string;
516 13         34 my $argv = "-npro -pbp -nst -se -nola -t";
517              
518 13         105 my $error = Perl::Tidy::perltidy(
519             argv => $argv,
520             source => \$source,
521             destination => \$dest_string,
522             stderr => \$stderr_string,
523             errorfile => \$errorfile_string,
524             );
525              
526 13 100       2382765 if ($stderr_string) {
527             # serious error in input parameters, no tidied output
528 1         76 print "<<STDERR>>\n$stderr_string\n";
529 1         14 die "Exiting because of serious errors\n";
530             }
531              
532 12         364 return $dest_string;
533             }
534              
535             sub _build_tests {
536 4     4   19 my ($class, $obj_ok) = @_;
537 4         37 my $tests = sprintf("our (\$sub, \$globref); BEGIN { use_ok('%s'); \$sub = sub {}; \$globref = \\*globref; }", $class->{NAME});
538              
539 4 100       44 if ($class->{CLASS_TESTS}) {
540 1         3 my $c = 1;
541 1         2 for my $subset (@{$class->{CLASS_TESTS}}) {
  1         5  
542             $tests .= sprintf "subtest 'class_tests$c' => sub { plan tests => %s; %s };",
543 2         3 scalar @{$subset},
544 2         7 join( '', map{ _build_test($_) } @{ $subset });
  6         13  
  2         5  
545 2         7 $c++;
546             }
547             }
548              
549 4 100       25 if ($class->{SUBS}->{new}->{TEST}) {
550             $tests .= sprintf "subtest 'new' => sub { plan tests => %s; %s };",
551 2         8 scalar @{$class->{SUBS}->{new}->{TEST}},
552 2         5 join '', map{ _build_test($_) } @{ $class->{SUBS}->{new}->{TEST} };
  4         23  
  2         9  
553 2         8 $obj_ok = $class->{SUBS}->{new}->{TEST}->[0];
554             }
555              
556 4         13 for my $sub (sort {
557 8   100     60 ($class->{SUBS}{$a}{INDEX} || 0) <=> ($class->{SUBS}{$b}{INDEX} ||0)
      100        
558 4         38 } keys %{$class->{SUBS}}) {
559 10 100       30 next if $sub eq 'new';
560 6 100       17 unshift @{$class->{SUBS}->{$sub}->{TEST}}, $obj_ok if $obj_ok;
  3         11  
561             $tests .= sprintf "subtest '%s' => sub { plan tests => %s; %s };",
562             ($class->{SUBS}->{$sub}->{KEYWORD} ? ( $class->{SUBS}->{$sub}->{KEYWORD} . ' ' . quotemeta($class->{SUBS}->{$sub}->{$class->{SUBS}->{$sub}->{KEYWORD}}) ) : $sub),
563 6         19 scalar @{$class->{SUBS}->{$sub}->{TEST}},
564 25         54 join '', map{ _build_test($_) } @{ $class->{SUBS}->{$sub}->{TEST} }
  6         30  
565 6 100       37 if $class->{SUBS}->{$sub}->{TEST};
    50          
566             }
567              
568 4         34 return $tests;
569             }
570              
571             our %TESTS;
572             BEGIN {
573             %TESTS = (
574             ok => sub {
575 11   33     88 return sprintf q|ok(%s, q{%s});|, $_[1], $_[2] || $_[1];
576             },
577             can_ok => sub {
578 3         10 return sprintf q|can_ok(%s, %s);|, $_[1], $_[2];
579             },
580             isa_ok => sub {
581 2         19 return sprintf q|isa_ok(%s, %s);|, $_[1], $_[2];
582             },
583             is => sub {
584 14   33     90 return sprintf q|is(%s, %s, q{%s});|, $_[1], $_[2], $_[3] || $_[1];
585             },
586             isnt => sub {
587 0   0     0 return sprintf q|isnt(%s, %s, q{%s});|, $_[1], $_[2], $_[3] || $_[1];
588             },
589             like => sub {
590 0   0     0 return sprintf q|like(%s, %s, q{%s});|, $_[1], $_[2], $_[3] || $_[1];
591             },
592             unlike => sub {
593 0   0     0 return sprintf q|unlike(%s, %s, q{%s});|, $_[1], $_[2], $_[3] || $_[1];
594             },
595             deep => sub {
596 4   33     31 return sprintf q|is_deeply(%s, %s, q{%s});|, $_[1], $_[2], $_[3] || $_[1];
597             },
598             eval => sub {
599 1   33     15 return sprintf q|eval {%s}; like($@, qr/%s/, q{%s});|, $_[1], $_[2], $_[3] || $_[1];
600             }
601 6     6   691 );
602             }
603              
604             sub _build_test {
605 35     35   50 my $test = shift;
606 35 50       73 return ref $test ? $TESTS{$test->[0]}->(@{$test}) : $test;
  35         117  
607             }
608              
609             1;
610              
611             __DATA__
612              
613             =head1 NAME
614              
615             {{name}} - {{abstract}}
616              
617             =head1 VERSION
618              
619             Version {{version}}
620              
621             =cut
622              
623             =head1 SYNOPSIS
624              
625             {{synopsis}}
626              
627             {{subs}}
628              
629             =head1 AUTHOR
630              
631             {{author}}, C<< <{{email}}> >>
632              
633             =head1 BUGS
634              
635             Please report any bugs or feature requests to C<bug-{{lcname}} at rt.cpan.org>, or through
636             the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue={{safename}}>. I will be notified, and then you'll
637             automatically be notified of progress on your bug as I make changes.
638              
639             =head1 SUPPORT
640              
641             You can find documentation for this module with the perldoc command.
642              
643             perldoc {{name}}
644              
645             You can also look for information at:
646              
647             =over 4
648              
649             =item * RT: CPAN's request tracker (report bugs here)
650              
651             L<https://rt.cpan.org/NoAuth/Bugs.html?Dist={{safename}}>
652              
653             =item * AnnoCPAN: Annotated CPAN documentation
654              
655             L<http://annocpan.org/dist/{{safename}}>
656              
657             =item * CPAN Ratings
658              
659             L<https://cpanratings.perl.org/d/{{safename}}>
660              
661             =item * Search CPAN
662              
663             L<https://metacpan.org/release/{{safename}}>
664              
665             =back
666              
667             =head1 ACKNOWLEDGEMENTS
668              
669             =head1 LICENSE AND COPYRIGHT
670              
671             This software is Copyright (c) 2020 by {{author}}.
672              
673             This is free software, licensed under:
674              
675             The Artistic License 2.0 (GPL Compatible)
676              
677             =cut
678              
679             __END__
680              
681             =head1 NAME
682              
683             Module::Generate - Assisting with module generation.
684              
685             =head1 VERSION
686              
687             Version 0.26
688              
689             =cut
690              
691             =head1 SYNOPSIS
692              
693             use Module::Generate;
694              
695             Module::Generate->dist('Planes')
696             ->author('LNATION')
697             ->email('email@lnation.org')
698             ->version('0.01')
699             ->class('Planes')
700             ->abstract('Over my head.')
701             ->our('$type')
702             ->begin(sub {
703             $type = 'boeing';
704             })
705             ->new
706             ->pod('Instantiate a new plane.')
707             ->example('my $plane = Planes->new')
708             ->accessor('airline')
709             ->sub('type')
710             ->code(sub { $type })
711             ->pod('Returns the type of plane.')
712             ->example('$plane->type')
713             ->sub('altitude')
714             ->code(sub {
715             $_[1] / $_[2];
716             ...
717             })
718             ->pod('Discover the altitude of the plane.')
719             ->example('$plane->altitude(100, 100)')
720             ->generate;
721              
722             ...
723              
724             Module::Generate->dist('Holiday')
725             ->author('LNATION')
726             ->email('email@lnation.org')
727             ->version('0.01')
728             ->class('Feed::Data')
729             ->use('Data::LnArray')
730             ->our('$holiday')
731             ->begin(sub {
732             $holiday = Data::LnArray->new;
733             })
734             ->sub('parse')
735             ->sub('write')
736             ->sub('render')
737             ->sub('generate')
738             ->sub('_raw')
739             ->sub('_text')
740             ->sub('_json')
741             ->generate;
742              
743             =head1 SUBROUTINES/METHODS
744              
745             =head2 start
746              
747             Instantiate a new Module::Generate object.
748              
749             my $mg = Module::Generate->start;
750              
751             =head2 dist
752              
753             Provide a name for the distribution.
754              
755             my $dist = Module::Generate->dist('Planes');
756              
757             =cut
758              
759             =head2 lib
760              
761             Provide a path where the generated files will be compiled.
762              
763             my $module = Module::Generate->lib('./path/to/lib');
764              
765             =cut
766              
767             =head2 tlib
768              
769             Provide a path where the generated test will be compiled.
770              
771             my $module = Module::Generate->tlib('./path/to/t');
772              
773             =cut
774              
775             =head2 author
776              
777             The author of the distribution/module.
778              
779             my $module = Module::Generate->author('LNATION');
780              
781             =cut
782              
783             =head2 email
784              
785             The authors email of the distribution/module.
786              
787             my $module = Module::Generate->email('email@lnation.org');
788              
789             =cut
790              
791             =head2 version
792              
793             The version number of the distribution/module.
794              
795             my $version = Module::Generate->version('0.01');
796              
797             =cut
798              
799             =head2 class
800              
801             Start a new class/package/module..
802              
803             my $class = Module::Generate->class('Planes');
804              
805             =cut
806              
807             =head2 abstract
808              
809             Provide abstract text for the class.
810              
811             $class->abstract('Over my head.');
812              
813             =head2 synopsis
814              
815             Provide a synopsis for the class.
816              
817             $class->synopsis('...');
818              
819             =cut
820              
821             =head2 use
822              
823             Declare modules that should be included in the class.
824              
825             $class->use(qw/Moo MooX::LazierAttributes/);
826              
827             =cut
828              
829             =head2 base
830              
831             Establish an ISA relationship with base classes at compile time.
832              
833             Unless you are using the fields pragma, consider this discouraged in favor of the lighter-weight parent.
834              
835             $class->base(qw/Foo Bar/);
836              
837             =cut
838              
839             =head2 parent
840              
841             Establish an ISA relationship with base classes at compile time.
842              
843             $class->parent(qw/Foo Bar/);
844              
845             =cut
846              
847             =head2 require
848              
849             Require library files to be included if they have not already been included.
850              
851             $class->require(qw/Foo Bar/);
852              
853             =cut
854              
855             =head2 our
856              
857             Declare variable of the same name in the current package for use within the lexical scope.
858              
859             $class->our(qw/$one $two/);
860              
861             =cut
862              
863             =head2 begin
864              
865             Define a code block is executed as soon as possible.
866              
867             $class->begin(sub {
868             ...
869             });
870              
871             =cut
872              
873             =head2 unitcheck
874              
875             Define a code block that is executed just after the unit which defined them has been compiled.
876              
877             $class->unitcheck(sub {
878             ...
879             });
880              
881             =cut
882              
883             =head2 check
884              
885             Define a code block that is executed just after the initial Perl compile phase ends and before the run time begins.
886              
887             $class->check(sub {
888             ...
889             });
890              
891             =cut
892              
893             =head2 init
894              
895             Define a code block that is executed just before the Perl runtime begins execution.
896              
897             $class->init(sub {
898             ...
899             });
900              
901             =cut
902              
903             =head2 end
904              
905             Define a code block is executed as late as possible.
906              
907             $class->end(sub {
908             ...
909             });
910              
911             =cut
912              
913             =head2 new
914              
915             Define an object constructor.
916              
917             $class->new;
918              
919             equivalent to:
920              
921             sub new {
922             my ($cls, %args) = (shift, scalar @_ == 1 ? %{$_[0]} : @_);
923             bless \%args, $cls;
924             }
925              
926             optionally you can pass your own sub routine.
927              
928             $class->new(sub { ... });
929              
930             =head2 accessor
931              
932             Define a accessor.
933              
934             $class->accessor('test');
935              
936             equivalent to:
937              
938             sub test {
939             my ($self, $value) = @_;
940             if ($value) {
941             $self->{$sub} = $value;
942             }
943             return $self->{$sub}
944             }";
945              
946             =head2 sub
947              
948             Define a sub routine/method.
949              
950             my $sub = $class->sub('name');
951              
952             =cut
953              
954             =head2 code
955              
956             Define the code that will be run for the sub.
957              
958             $sub->code(sub {
959             return 'Robert';
960             });
961              
962             =cut
963              
964             =head2 pod
965              
966             Provide pod text that describes the sub.
967              
968             $sub->pod('What is my name?');
969              
970             =cut
971              
972             =head2 example
973              
974             Provide a code example which will be suffixed to the pod definition.
975              
976             $sub->example('$foo->name');
977              
978             =cut
979              
980             =head2 test
981              
982             Provide tests for the sub.
983              
984             $sub->test(['is', '$obj->name', q|'test'|], [ ... ], ...)
985              
986             =cut
987              
988             =head2 macro
989              
990             Implement a macro that can be inserted across classes.
991              
992             my $mg = Module::Generate->author('LNATION')
993             ->email('email@lnation.org')
994             ->version('0.01');
995             $mg->macro('self', sub {
996             my ($self, $value) = @_;
997             });
998             my $class = $mg->class('Foo');
999             $class->sub('bar')
1000             ->code(sub { &self; $value; });
1001             $class->generate;
1002              
1003             ###
1004              
1005             package Foo;
1006             use strict;
1007             use warnings;
1008             our $VERSION = 0.01;
1009              
1010             sub bar {
1011             my ( $self, $value ) = @_;
1012              
1013             $value;
1014             }
1015              
1016             1;
1017              
1018             __END__
1019              
1020             =head2 keyword
1021              
1022             Implement a keyword that can be used accross classes.
1023              
1024              
1025             my $mg = Module::Generate
1026             ->author('LNATION')
1027             ->email('email@lnation.org');
1028             $mg->keyword('with', sub {
1029             my ($meta) = @_;
1030             return qq|with $meta->{with};|;
1031             });
1032              
1033             $mg->keyword('has',
1034             CODE => sub {
1035             my ($meta) = @_;
1036             $meta->{is} ||= q|'ro'|;
1037             my $attributes = join ', ', map {
1038             ($meta->{$_} ? (sprintf "%s => %s", $_, $meta->{$_}) : ())
1039             } qw/is required/;
1040             my $code = qq|
1041             has $meta->{has} => ( $attributes );|;
1042             return $code;
1043             },
1044             KEYWORDS => [qw/is required/],
1045             POD_TITLE => 'ATTRIBUTES',
1046             POD_POD => 'get or set $keyword',
1047             POD_EXAMPLE => "\$obj->\$keyword;\n\n\t\$obj->\$keyword(\$value);"
1048             );
1049              
1050             $mg->class('Keyword')
1051             ->use('Moo')
1052             ->with(qw/'Keyword::Role'/)
1053             ->test(
1054             ['ok', q|my $obj = Keyword->new( thing => 'abc', test => 'def' )|],
1055             ['is', q|$obj->test|, q|'def'|]
1056             )
1057             ->has('thing')->required(1)
1058             ->test(
1059             ['ok', q|my $obj = Keyword->new( thing => 'abc' )|],
1060             ['is', q|$obj->thing|, q|'abc'|],
1061             ['eval', q|$obj = Keyword->new()|, 'required']
1062             );
1063              
1064             $mg->class('Keyword::Role')
1065             ->use('Moo::Role')
1066             ->has('test')->is(q|'rw'|)
1067             ->test(
1068             ['ok', q|my $obj = do { eval q{
1069             package FooBar;
1070             use Moo;
1071             with 'Keyword::Role';
1072             1;
1073             }; 1; } && FooBar->new| ],
1074             ['is', q|$obj->test|, q|undef|],
1075             ['ok', q|$obj->test('abc')|],
1076             ['is', q|$obj->test|, q|'abc'|]
1077             );
1078              
1079             =head2 class_tests
1080              
1081             Define additional subtests for a class.
1082              
1083             $mg->class_tests([
1084             ['ok', q|my $obj = do { eval q{
1085             package FooBar;
1086             use Moo;
1087             with 'Keyword::Role';
1088             1;
1089             }; 1; } && FooBar->new| ],
1090             ['is', q|$obj->test|, q|undef|],
1091             ['ok', q|$obj->test('abc')|],
1092             ['is', q|$obj->test|, q|'abc'|]
1093             ], [
1094             ['ok', q|my $obj = do { eval q{
1095             package BarFoo;
1096             use Moo;
1097             with 'Keyword::Role';
1098             1;
1099             }; 1; } && BarFoo->new| ],
1100             ['is', q|$obj->test|, q|undef|],
1101             ['ok', q|$obj->test('abc')|],
1102             ['is', q|$obj->test|, q|'abc'|]
1103             ]);
1104              
1105              
1106             =head2 generate
1107              
1108             Compile the code.
1109              
1110             $sub->generate(%args);
1111              
1112             =cut
1113              
1114             =head1 AUTHOR
1115              
1116             LNATION, C<< <email at lnation.org> >>
1117              
1118             =head1 BUGS
1119              
1120             Please report any bugs or feature requests to C<bug-module-generate at rt.cpan.org>, or through
1121             the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Module-Generate>. I will be notified, and then you'll
1122             automatically be notified of progress on your bug as I make changes.
1123              
1124             =head1 SUPPORT
1125              
1126             You can find documentation for this module with the perldoc command.
1127              
1128             perldoc Module::Generate
1129              
1130             You can also look for information at:
1131              
1132             =over 4
1133              
1134             =item * RT: CPAN's request tracker (report bugs here)
1135              
1136             L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Generate>
1137              
1138             =item * AnnoCPAN: Annotated CPAN documentation
1139              
1140             L<http://annocpan.org/dist/Module-Generate>
1141              
1142             =item * CPAN Ratings
1143              
1144             L<https://cpanratings.perl.org/d/Module-Generate>
1145              
1146             =item * Search CPAN
1147              
1148             L<https://metacpan.org/release/Module-Generate>
1149              
1150             =back
1151              
1152             =head1 ACKNOWLEDGEMENTS
1153              
1154             =head1 LICENSE AND COPYRIGHT
1155              
1156             This software is Copyright (c) 2020 by LNATION.
1157              
1158             This is free software, licensed under:
1159              
1160             The Artistic License 2.0 (GPL Compatible)
1161              
1162             =cut
1163              
1164             1; # End of Module::Generate