File Coverage

blib/lib/Module/Generate.pm
Criterion Covered Total %
statement 350 357 98.0
branch 120 120 100.0
condition 35 55 63.6
subroutine 55 56 98.2
pod 30 33 90.9
total 590 621 95.0


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