File Coverage

blib/lib/Parse/Eyapp/Options.pm
Criterion Covered Total %
statement 38 44 86.3
branch 14 28 50.0
condition n/a
subroutine 8 8 100.0
pod 0 3 0.0
total 60 83 72.2


line stmt bran cond sub pod time code
1             #
2             # Module Parse::Eyapp::Options
3             #
4             # Copyright © 2006, 2007, 2008, 2009, 2010, 2011, 2012 Casiano Rodriguez-Leon.
5             # Copyright © 2017 William N. Braswell, Jr.
6             # All Rights Reserved.
7             #
8             # Based on Parse::Yapp.
9             #
10             # Parse::Yapp is Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
11             # Parse::Yapp is Copyright © 2017 William N. Braswell, Jr.
12             # All Rights Reserved.
13              
14             package Parse::Eyapp::Options;
15              
16 61     61   338 use strict;
  61         123  
  61         1567  
17 61     61   281 use Carp;
  61         109  
  61         35736  
18              
19             ############################################################################
20             #Definitions of options
21             #
22             # %known_options allowed options
23             #
24             # %default_options default
25             #
26             # %actions sub refs to execute if option is set with ($self,$value)
27             # as parameters
28             ############################################################################
29             #
30             #A value of '' means any value can do
31             #
32             my(%known_options)= (
33             language => {
34             perl => "Ouput parser for Perl language",
35             # for future use...
36             # 'c++' => "Output parser for C++ language",
37             # c => "Output parser for C language"
38             },
39             linenumbers => {
40             0 => "Don't embbed line numbers in parser",
41             1 => "Embbed source line numbers in parser"
42             },
43             firstline => {
44             '' => "Line number where the input grammar starts"
45             },
46             inputfile => {
47             '' => "Input file name: will automagically fills input"
48             },
49             prefix => {
50             '' => "Accept if a prefix of the input belongs to the language"
51             },
52             classname => {
53             '' => "Class name of parser object (Perl and C++)"
54             },
55             standalone => {
56             0 => "Don't create a standalone parser (Perl and C++)",
57             1 => "Create a standalone parser"
58             },
59             buildingtree => {
60             0 => "Not building AST (for lists)",
61             1 => "Building AST (for lists)"
62             },
63             input => {
64             '' => "Input text of grammar"
65             },
66             template => {
67             '' => "Template text for generating grammar file"
68             },
69             prefixname => {
70             '' => "Prefix for the Tree Classes"
71             },
72             modulino => {
73             '' => "Produce modulino code at the end of the generated module"
74             },
75             start => {
76             '' => "Specify start symbol"
77             },
78             tree => {
79             0 => "don't build AST",
80             1 => "build AST"
81             },
82             nocompact => {
83             0 => "Do not compact action tables. No DEFAULT field for 'STATES'",
84             1 => "Compact action tables"
85             },
86             lexerisdefined => {
87             0 => "Built a lexer",
88             1 => "don't build a lexer"
89             },
90             );
91              
92             my(%default_options)= (
93             language => 'perl',
94             firstline => 1,
95             linenumbers => 1,
96             inputfile => undef,
97             classname => 'Parser',
98             standalone => 0,
99             buildingtree => 1,
100             input => undef,
101             template => undef,
102             shebang => undef,
103             prefixname => '',
104             modulino => undef,
105             tree => undef,
106             nocompact => 0,
107             lexerisdefined => 0,
108             );
109              
110             my(%actions)= (
111             inputfile => \&__LoadFile
112             );
113              
114             #############################################################################
115             #
116             # Actions
117             #
118             # These are NOT a method, although they look like...
119             #
120             # They are super-private routines (that's why I prepend __ to their names)
121             #
122             #############################################################################
123             sub __LoadFile {
124 54     54   181 my($self,$filename)=@_;
125              
126 54 50       313 return if defined($self->{OPTIONS}{input});
127              
128 0 0       0 open(IN,"<$filename")
129             or croak "Cannot open input file '$filename' for reading";
130 0         0 $self->{OPTIONS}{input}=join('',);
131 0         0 close(IN);
132             }
133              
134             #############################################################################
135             #
136             # Private methods
137             #
138             #############################################################################
139              
140             sub _SetOption {
141 270     270   543 my($self)=shift;
142 270         606 my($key,$value)=@_;
143              
144 270         622 $key=lc($key);
145              
146 270 50       752 @_ == 2
147             or croak "Invalid number of arguments";
148              
149 270 50       811 exists($known_options{$key})
150             or croak "Unknown option: '$key'";
151              
152 270 100       1773 if(exists($known_options{$key}{lc($value)})) {
    50          
153 54 50       248 $value=lc($value) if defined($value);
154             }
155             elsif(not exists($known_options{$key}{''})) {
156 0         0 croak "Invalid value '$value' for option '$key'";
157             }
158              
159             exists($actions{$key})
160 270 100       868 and &{$actions{$key}}($self,$value);
  54         238  
161              
162 270         1413 $self->{OPTIONS}{$key}=$value;
163             }
164              
165             sub _GetOption {
166 1192     1192   1934 my($self)=shift;
167 1192         2019 my($key)=map { lc($_) } @_;
  1192         3023  
168              
169 1192 50       2909 @_ == 1
170             or croak "Invalid number of arguments";
171              
172 1192 50       3038 exists($known_options{$key})
173             or croak "Unknown option: '$key'";
174              
175 1192         4721 $self->{OPTIONS}{$key};
176             }
177              
178             #############################################################################
179             #
180             # Public methods
181             #
182             #############################################################################
183              
184             #
185             # Constructor
186             #
187             sub new {
188 54     54 0 162 my($class)=shift;
189 54         701 my($self)={ OPTIONS => { %default_options } };
190              
191 54 50       266 ref($class)
192             and $class=ref($class);
193            
194 54         186 bless($self,$class);
195              
196 54         426 $self->Options(@_);
197              
198 54         201 $self;
199             }
200              
201             #
202             # Specify one or more options to set
203             #
204             sub Options {
205 108     108 0 272 my($self)=shift;
206 108         296 my($key,$value);
207              
208 108 50       473 @_ % 2 == 0
209             or croak "Invalid number of arguments";
210              
211 108         621 while(($key,$value)=splice(@_,0,2)) {
212 270         949 $self->_SetOption($key,$value);
213             }
214             }
215              
216             #
217             # Set (2 parameters) or Get (1 parameter) values for one option
218             #
219             sub Option {
220 1192     1192 0 2102 my($self)=shift;
221 1192         2224 my($key,$value)=@_;
222              
223 1192 50       3724 @_ == 1
224             and return $self->_GetOption($key);
225              
226 0 0         @_ == 2
227             and return $self->_SetOption($key,$value);
228              
229 0           croak "Invalid number of arguments";
230              
231             }
232              
233             1;
234              
235             __END__