File Coverage

blib/lib/Text/NumericData/App.pm
Criterion Covered Total %
statement 95 108 87.9
branch 50 76 65.7
condition 3 9 33.3
subroutine 9 10 90.0
pod 4 6 66.6
total 161 209 77.0


line stmt bran cond sub pod time code
1             package Text::NumericData::App;
2              
3 14     14   4274 use Text::NumericData;
  14         46  
  14         585  
4 14     14   8317 use Config::Param;
  14         246182  
  14         666  
5 14     14   147 use Storable;
  14         39  
  14         1025  
6 14     14   219 use strict;
  14         42  
  14         20316  
7              
8             # This is just a placeholder because of a past build system bug.
9             # The one and only version for Text::NumericData is kept in
10             # the Text::NumericData module itself.
11             our $VERSION = '1';
12             $VERSION = eval $VERSION;
13              
14             my %shorts = (strict=>'S', text=>'T', numformat=>'N');
15              
16             sub new
17             {
18 19     19 0 59 my $class = shift;
19 19         53 my $self = {};
20 19         52 bless $self, $class;
21 19         116 $self->{setup} = shift; # main, parconf, pardef, exclude_pars
22 19         62 $self->{state} = {};
23              
24             # safety check for misspelled keys
25 19         133 my @known_setup =
26             (qw(
27             parconf
28             pardef
29             exclude
30             filemode
31             pipemode
32             pipe_init
33             pipe_file
34             pipe_prefilter
35             pipe_begin
36             pipe_line
37             pipe_end
38             pipe_allend
39             pipe_header
40             pipe_data
41             pipe_first_data
42             ));
43 19         49 my @unknown_keys = grep {my $k = $_; not grep {$_ eq $k} @known_setup;} (keys %{$self->{setup}});
  97         176  
  97         185  
  1455         3035  
  19         96  
44 19 50       91 print STDERR "WARNING: Text::NumericData::App got unknown setup keys (@unknown_keys)\n" if @unknown_keys;
45              
46 19 100       81 if($self->{setup}{pipemode})
47             {
48             # Activate pipe processing only on request.
49 13         4175 require Text::ASCIIPipe;
50             }
51              
52 19 50       14712 $self->{setup}{parconf} = {} unless defined $self->{setup}{parconf};
53             # Always return.
54 19         67 $self->{setup}{parconf}{noexit} = 1;
55              
56             # Lazyness ... why specify this again and again?
57             $self->{setup}{parconf}{copyright} = $Text::NumericData::copyright
58 19 50       105 unless defined $self->{setup}{parconf}{copyright};
59             $self->{setup}{parconf}{version} = $Text::NumericData::version
60 19 50       97 unless defined $self->{setup}{parconf}{version};
61             $self->{setup}{parconf}{author} = $Text::NumericData::author
62 19 50       96 unless defined $self->{setup}{parconf}{author};
63              
64 19 100       97 $self->{setup}{pardef} = [] unless defined $self->{setup}{pardef};
65 19         129 my $prob = Config::Param::sane_pardef($self->{setup}{parconf}, $self->{setup}{pardef});
66 19 50       6419 if($prob ne '')
67             {
68 0         0 print STDERR "Error in given parameter definiton: $prob\nThis is a fatal programming error.\n";
69 0         0 return undef;
70             }
71             # I'm sure this can be done more elegantly.
72 19 50       199 $self->add_param('Text::NumericData'
73             , \%Text::NumericData::defaults, \%Text::NumericData::help)
74             or return undef;
75 19 50       93 $self->add_param('Text::NumericData::File'
76             , \%Text::NumericData::File::defaults, \%Text::NumericData::File::help)
77             or return undef;
78              
79 19         125 return $self;
80             }
81              
82             sub add_param
83             {
84 38     38 0 85 my $self = shift;
85 38         109 my ($pkgname, $defaults, $help) = @_;
86 38         73 for my $pn (keys %{$defaults})
  38         208  
87             {
88 270 50 33     763 next if (defined $self->{setup}{exclude} and grep {$_ eq $pn} @{$self->{setup}{exclude}});
  0         0  
  0         0  
89 270         542 my $help = $help->{$pn};
90 270 50       565 $help = "some $pkgname parameter" unless defined $help;
91 270         782 $help .= " (from $pkgname)";
92             my $thisdef =
93             {
94             long=>$pn
95             , short=>$shorts{$pn}
96             # No deep copy here, as the calls to Config::Param get copies of this.
97 270         1033 , value=>$defaults->{$pn}
98             , help=>$help
99             };
100 270 50       880 if(Config::Param::sane_pardef($self->{setup}{parconf}, [$thisdef]) ne '')
101             {
102 0         0 print STDERR "Unexpected failure to sanitize param definiton for $pn.\n";
103 0         0 return undef;
104             }
105 270         18034 push(@{$self->{setup}{pardef}}, $thisdef);
  270         940  
106             }
107 38         165 return 1;
108             }
109              
110             sub run
111             {
112 43     43 1 32717 my ($self, $argv, $in, $out) = @_;
113 43 50       226 $argv = \@ARGV unless defined $argv;
114 43 100       188 $in = \*STDIN unless defined $in;
115 43 50       163 $out = \*STDOUT unless defined $out;
116 43         178 binmode $in;
117 43         198 binmode $out;
118 43         157 $self->{argv} = $argv;
119 43         140 $self->{in} = $in;
120 43         136 $self->{out} = $out;
121              
122 43         85 my $errors;
123             # Ensure that Config::Param cannot mess with our default values by
124             # providing deep copies of configuration. Even if it behaves nice,
125             # better safe than sorry.
126             $self->{param} = Config::Param::get(
127             Storable::dclone($self->{setup}{parconf})
128             , Storable::dclone($self->{setup}{pardef})
129 43         5825 , $self->{argv}, $errors );
130              
131 43 50       288564 if(@{$errors})
  43         258  
132             {
133 0         0 print STDERR "Stopping here because of parameter parsing errors.\n";
134 0         0 return 1;
135             }
136 43 50 33     405 return 0 if($self->{param}{help} or $self->{param}{version});
137              
138 43 100       215 if($self->{setup}{pipemode})
139             {
140 36 100       177 if(defined $self->{setup}{pipe_init})
141             {
142 32         206 my $err = $self->{setup}{pipe_init}->($self);
143 32 50       175 if($err)
144             {
145 0         0 print STDERR "Pipe init handler failed, aborting.\n";
146 0         0 return $err;
147             }
148             }
149 36 100       161 if($self->{setup}{filemode})
150             {
151             # Not wholly sure about that logic, have to really test and then delete this comment.
152 11         37 while(1)
153             {
154 11         90 $self->new_txd();
155 11         55 my $ret = $self->{txd}->read_all($self->{in});
156             $self->{setup}{pipe_file}->($self)
157 11 50 33     131 if ($ret >= 0 and defined $self->{setup}{pipe_file});
158 11 50       54 last if $ret <= 0;
159             }
160             $self->{setup}{pipe_allend}->($self)
161 11 50       59 if defined $self->{setup}{pipe_allend};
162             Text::ASCIIPipe::done($self->{out})
163 11 50       48 if $self->{txd}{config}{pipemode};
164             }
165             else
166             {
167             Text::ASCIIPipe::process
168             (
169             handle => $self
170             ,in => $self->{in}
171             ,out => $self->{out}
172             ,pre => $self->{setup}{pipe_prefilter}
173             ,begin => defined $self->{setup}{pipe_begin} ? $self->{setup}{pipe_begin} : \&new_txd
174             ,line => defined $self->{setup}{pipe_line} ? $self->{setup}{pipe_line} : \&default_line_hook
175             ,end => $self->{setup}{pipe_end}
176             ,allend => $self->{setup}{pipe_allend}
177 25 50       381 );
    100          
178             }
179 36         1321 return 0;
180             }
181             else
182             {
183 7         72 $self->new_txd();
184 7         42 return $self->main();
185             }
186             }
187              
188             sub new_txd
189             {
190 41     41 1 148 my $self = shift;
191 41 100       1906 require Text::NumericData::File if $self->{setup}{filemode};
192              
193             $self->{txd} = $self->{setup}{filemode}
194             ? Text::NumericData::File->new($self->{param})
195 41 100       440 : Text::NumericData->new($self->{param});
196              
197 41         171 $self->{state}{data} = 0;
198             }
199              
200              
201             sub default_line_hook
202             {
203 474     474 1 17287 my $self = shift;
204 474         982 my $prefix = undef;
205 474 100       1469 if(!$self->{state}{data})
206             {
207 33 100       167 if($self->{txd}->line_check($_[0]))
208             {
209 15         50 $self->{state}{data} = 1;
210             $prefix = $self->{setup}{pipe_first_data}->($self, @_)
211 15 100       77 if defined $self->{setup}{pipe_first_data};
212             }
213             else
214             {
215             $self->{setup}{pipe_header}->($self, @_)
216 18 100       142 if defined $self->{setup}{pipe_header};
217 18         59 return;
218             }
219             }
220             # If still here, $self->{state}{data} == 1 is implied.
221             $self->{setup}{pipe_data}->($self, @_)
222 456 50       2282 if defined $self->{setup}{pipe_data};
223 456 100       2024 $_[0] = ${$prefix}.$_[0]
  3         14  
224             if defined $prefix;
225             }
226              
227             sub error
228             {
229 0     0 1   my $self = shift;
230 0 0         print STDERR "$_[0]\n" if defined $_[0];
231 0 0         return defined $_[1] ? $_[1] : -1;
232             }
233              
234             1;
235              
236             __END__