File Coverage

blib/lib/Getopt/Config/FromPod.pm
Criterion Covered Total %
statement 77 81 95.0
branch 20 26 76.9
condition 14 25 56.0
subroutine 18 18 100.0
pod 6 6 100.0
total 135 156 86.5


line stmt bran cond sub pod time code
1             package Getopt::Config::FromPod;
2              
3 6     6   22589 use strict;
  6         12  
  6         265  
4 6     6   36 use warnings;
  6         10  
  6         963  
5              
6             # ABSTRACT: Extract getopt configuration from POD
7             our $VERSION = 'v0.0.3'; # VERSION
8              
9             package Getopt::Config::FromPod::Extractor;
10              
11 6     6   29 use strict;
  6         15  
  6         193  
12 6     6   26 use warnings;
  6         14  
  6         199  
13              
14 6     6   3246 use parent qw(Pod::Simple);
  6         2153  
  6         36  
15              
16             sub new
17             {
18 16     16   34 my ($ref, %args) = @_;
19 16   33     91 my $class = ref $ref || $ref;
20 16         80 my $self = bless Pod::Simple::new($class, %args), $class;
21 16   100     539 my $tag = $args{-tag} || 'getopt';
22 16         80 $self->{_TAG} = $tag;
23 16         79 $self->accept_targets($tag);
24 16         3067 return $self;
25             }
26              
27             sub _handle_element_start
28             {
29 292     292   44820 my ($parser, $element_name, $attr) = @_;
30 292 100       618 if($element_name eq 'Document') {
31 16         47 $parser->{_RESULT} = [];
32             }
33 292 100 66     1491 if(($element_name eq 'for' || $element_name eq 'begin') && $attr->{target} eq $parser->{_TAG}) {
      66        
34 49         127 $parser->{_IN_TARGET} = 1;
35             }
36             }
37              
38             sub _handle_element_end
39             {
40 292     292   4339 my ($parser, $element_name, $attr) = @_;
41 292 100 33     1084 if($element_name eq 'for' || ($element_name eq 'end' && $attr->{target} eq $parser->{_TAG})) {
      66        
42 49         112 $parser->{_IN_TARGET} = 0;
43             }
44             }
45              
46             sub _handle_text
47             {
48 182     182   1157 my ($parser, $text) = @_;
49 182 100       461 push @{$parser->{_RESULT}}, eval $text if $parser->{_IN_TARGET}; ## no critic (ProhibitStringyEval)
  49         3253  
50             }
51              
52             package Getopt::Config::FromPod;
53              
54 6     6   187808 use Carp;
  6         15  
  6         3807  
55              
56             sub new
57             {
58 14     14 1 2875 my $self = shift;
59 14   33     78 my $class = ref $self || $self;
60 14         78 return bless { _ARG => \@_ }, $class;
61             }
62              
63             sub _extract
64             {
65 16     16   29 my ($self, %args) = @_;
66 16         19 %args = (@{$self->{_ARG}}, %args);
  16         88  
67 16         100 my $parser = Getopt::Config::FromPod::Extractor->new(%args);
68 16         42 my $file = $args{-file};
69 16   50     92 $args{-package} ||= 'main';
70 16 100       56 if(! defined $file) {
71 8         15 my $idx = 0;
72 8         11 my @caller;
73 8         44 while(@caller = caller($idx++)) {
74 22 100       451 if($caller[0] eq $args{-package}) {
75 8         15 $file = $caller[1];
76 8         14 last;
77             }
78             }
79 8 50       30 confess "Target module not found" if ! defined $file;
80             # At least, in PAR environment, this adjustment is necessary.
81 8 50       241 if(! -f $file) {
82 0         0 for my $inc (@INC) {
83 0 0       0 if(-f "$inc/$file") {
84 0         0 $file = "$inc/$file";
85 0         0 last;
86             }
87             }
88             }
89             }
90 16 50 66     230 croak "Target file not found: $file" if ref $file eq '' && ! -f $file;
91 16         82 $parser->parse_file($file);
92 16         786 return $parser->{_RESULT};
93             }
94              
95             my $SELF = __PACKAGE__->new;
96              
97             sub __ref
98             {
99 30     30   55 my $ref = shift;
100 30 100       97 return if ref $ref->[0];
101 6 50       11 croak 'Calling as neither instance method nor class method' unless eval { $ref->[0]->isa(__PACKAGE__) };
  6         64  
102 6         23 splice @$ref, 0, 1, $SELF;
103             }
104              
105             sub string
106             {
107 6     6 1 3909 __ref(\@_);
108 6         17 my ($self, %args) = @_;
109 6 100       45 return join(exists $args{-separator} ? $args{-separator} : '', $self->array(%args));
110             }
111              
112             sub array
113             {
114 16     16 1 46 __ref(\@_);
115 16         31 my ($self, %args) = @_;
116 16         19 return @{$self->_extract(%args)};
  16         49  
117             }
118              
119             sub arrayref
120             {
121 4     4 1 21 __ref(\@_);
122 4         15 my ($self, %args) = @_;
123 4         23 return [$self->array(%args)];
124             }
125              
126             sub hashref
127             {
128 4     4 1 20 __ref(\@_);
129 4         20 my ($self, %args) = @_;
130 4         17 return {$self->array(%args)};
131             }
132              
133             sub set_class_default
134             {
135 2     2 1 2322 my ($self, %args) = @_;
136 2         13 $SELF = __PACKAGE__->new(%args);
137             }
138              
139             1;
140              
141             __END__