File Coverage

blib/lib/Parse/Yapp/Options.pm
Criterion Covered Total %
statement 34 43 79.0
branch 10 24 41.6
condition n/a
subroutine 7 8 87.5
pod 0 3 0.0
total 51 78 65.3


line stmt bran cond sub pod time code
1             #
2             # Module Parse::Yapp::Options
3             #
4             # Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
5             # Copyright © 2017 William N. Braswell, Jr.
6             # (see the pod text in Parse::Yapp module for use and distribution rights)
7             #
8             package Parse::Yapp::Options;
9              
10 3     3   19 use strict;
  3         6  
  3         79  
11 3     3   15 use Carp;
  3         7  
  3         2180  
12              
13             ############################################################################
14             #Definitions of options
15             #
16             # %known_options allowed options
17             #
18             # %default_options default
19             #
20             # %actions sub refs to execute if option is set with ($self,$value)
21             # as parameters
22             ############################################################################
23             #
24             #A value of '' means any value can do
25             #
26             my(%known_options)= (
27             language => {
28             perl => "Ouput parser for Perl language",
29             # for future use...
30             # 'c++' => "Output parser for C++ language",
31             # c => "Output parser for C language"
32             },
33             linenumbers => {
34             0 => "Don't embbed line numbers in parser",
35             1 => "Embbed source line numbers in parser"
36             },
37             inputfile => {
38             '' => "Input file name: will automagically fills input"
39             },
40             classname => {
41             '' => "Class name of parser object (Perl and C++)"
42             },
43             standalone => {
44             0 => "Don't create a standalone parser (Perl and C++)",
45             1 => "Create a standalone parser"
46             },
47             input => {
48             '' => "Input text of grammar"
49             },
50             template => {
51             '' => "Template text for generating grammar file"
52             },
53             );
54              
55             my(%default_options)= (
56             language => 'perl',
57             linenumbers => 1,
58             inputfile => undef,
59             classname => 'Parser',
60             standalone => 0,
61             input => undef,
62             template => undef,
63             shebang => undef,
64             );
65              
66             my(%actions)= (
67             inputfile => \&__LoadFile
68             );
69              
70             #############################################################################
71             #
72             # Actions
73             #
74             # These are NOT a method, although they look like...
75             #
76             # They are super-private routines (that's why I prepend __ to their names)
77             #
78             #############################################################################
79             sub __LoadFile {
80 0     0   0 my($self,$filename)=@_;
81              
82 0 0       0 open(IN,"<$filename")
83             or croak "Cannot open input file '$filename' for reading";
84 0         0 $self->{OPTIONS}{input}=join('',);
85 0         0 close(IN);
86             }
87              
88             #############################################################################
89             #
90             # Private methods
91             #
92             #############################################################################
93              
94             sub _SetOption {
95 19     19   34 my($self)=shift;
96 19         35 my($key,$value)=@_;
97              
98 19         45 $key=lc($key);
99              
100 19 50       52 @_ == 2
101             or croak "Invalid number of arguments";
102              
103 19 50       54 exists($known_options{$key})
104             or croak "Unknown option: '$key'";
105              
106 19 50       341 if(exists($known_options{$key}{lc($value)})) {
    50          
107 0         0 $value=lc($value);
108             }
109             elsif(not exists($known_options{$key}{''})) {
110 0         0 croak "Invalid value '$value' for option '$key'";
111             }
112              
113             exists($actions{$key})
114 19 50       50 and &{$actions{$key}}($self,$value);
  0         0  
115              
116 19         89 $self->{OPTIONS}{$key}=$value;
117             }
118              
119             sub _GetOption {
120 101     101   147 my($self)=shift;
121 101         159 my($key)=map { lc($_) } @_;
  101         236  
122              
123 101 50       229 @_ == 1
124             or croak "Invalid number of arguments";
125              
126 101 50       231 exists($known_options{$key})
127             or croak "Unknown option: '$key'";
128              
129 101         328 $self->{OPTIONS}{$key};
130             }
131              
132             #############################################################################
133             #
134             # Public methods
135             #
136             #############################################################################
137              
138             #
139             # Constructor
140             #
141             sub new {
142 10     10 0 25 my($class)=shift;
143 10         72 my($self)={ OPTIONS => { %default_options } };
144              
145 10 50       35 ref($class)
146             and $class=ref($class);
147            
148 10         22 bless($self,$class);
149              
150 10         35 $self->Options(@_);
151              
152 10         29 $self;
153             }
154              
155             #
156             # Specify one or more options to set
157             #
158             sub Options {
159 19     19 0 35 my($self)=shift;
160 19         33 my($key,$value);
161              
162 19 50       61 @_ % 2 == 0
163             or croak "Invalid number of arguments";
164              
165 19         80 while(($key,$value)=splice(@_,0,2)) {
166 19         60 $self->_SetOption($key,$value);
167             }
168             }
169              
170             #
171             # Set (2 parameters) or Get (1 parameter) values for one option
172             #
173             sub Option {
174 101     101 0 176 my($self)=shift;
175 101         189 my($key,$value)=@_;
176              
177 101 50       275 @_ == 1
178             and return $self->_GetOption($key);
179              
180 0 0         @_ == 2
181             and return $self->_SetOption($key,$value);
182              
183 0           croak "Invalid number of arguments";
184              
185             }
186              
187             1;