File Coverage

blib/lib/Class/GenSource.pm
Criterion Covered Total %
statement 22 27 81.4
branch 4 10 40.0
condition 2 4 50.0
subroutine 4 4 100.0
pod 1 1 100.0
total 33 46 71.7


line stmt bran cond sub pod time code
1             package Class::GenSource;
2              
3             our $DATE = '2015-06-12'; # DATE
4             our $VERSION = '0.04'; # VERSION
5              
6 1     1   29845 use 5.010001;
  1         4  
  1         50  
7 1     1   6 use strict;
  1         2  
  1         41  
8 1     1   5 use warnings;
  1         1  
  1         534  
9              
10             require Exporter;
11             our @ISA = qw(Exporter);
12             our @EXPORT_OK = qw(gen_class_source_code);
13              
14             our %SPEC;
15              
16             my $re_ident = qr/\A[A-Za-z_][A-Za-z0-9_]*(::[A-Za-z_][A-Za-z0-9_]*)*\z/;
17              
18             $SPEC{gen_class_source_code} = {
19             v => 1.1,
20             summary => 'Generate Perl source code to declare a class',
21             description => <<'_',
22              
23             _
24             args => {
25             name => {
26             schema => ['str*', match=>$re_ident],
27             req => 1,
28             },
29             parent => {
30             schema => ['str*', match=>$re_ident],
31             },
32             attributes => {
33             schema => ['hash*', match=>$re_ident],
34             default => {},
35             },
36             variant => {
37             schema => ['str*', in=>[qw/classic Mo Moo Moose/]],
38             default => 'classic',
39             },
40             },
41             result_naked => 1,
42             };
43             sub gen_class_source_code {
44 1     1 1 14 my %args = @_;
45              
46             # XXX schema
47 1   50     9 my $variant = $args{variant} // 'classic';
48              
49 1         3 my @res;
50              
51 1         5 push @res, "package $args{name};\n";
52 1 50       7 if ($variant =~ /^Mo/) {
53 0         0 push @res, "use $variant;\n";
54             }
55              
56 1 50       7 if ($args{parent}) {
57 0 0       0 if ($variant =~ /^Mo/) {
58 0         0 push @res, "extends '$args{parent}';\n";
59             } else {
60 0         0 push @res, "use parent qw(", $args{parent}, ");\n";
61             }
62             }
63              
64 1 50       4 if ($variant eq 'classic') {
65 1         3 push @res, q[sub new { my $class = shift; bless {@_}, $class; }], "\n";
66             }
67              
68 1   50     4 my $attrs = $args{attributes} // {};
69 1         8 for my $name (sort keys %$attrs) {
70 2 50       7 if ($variant =~ /^Mo/) {
71 0         0 push @res, "has $name => (is=>'rw');\n";
72             } else {
73 2         10 push @res, "sub $name { my \$self = shift; \$self->{'$name'} = \$_[0] if \@_; \$self->{'$name'} }\n";
74             }
75             }
76              
77 1         8 join("", @res);
78             }
79              
80             1;
81             # ABSTRACT: Generate Perl source code to declare a class
82              
83             __END__