File Coverage

blib/lib/Text/NumericData/App.pm
Criterion Covered Total %
statement 95 108 87.9
branch 49 76 64.4
condition 3 9 33.3
subroutine 9 10 90.0
pod 4 6 66.6
total 160 209 76.5


line stmt bran cond sub pod time code
1             package Text::NumericData::App;
2              
3 14     14   4297 use Text::NumericData;
  14         37  
  14         449  
4 14     14   12870 use Config::Param;
  14         293023  
  14         530  
5 14     14   116 use Storable;
  14         27  
  14         733  
6 14     14   83 use strict;
  14         59  
  14         20762  
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 54 my $class = shift;
19 19         49 my $self = {};
20 19         46 bless $self, $class;
21 19         103 $self->{setup} = shift; # main, parconf, pardef, exclude_pars
22 19         53 $self->{state} = {};
23              
24             # safety check for misspelled keys
25 19         145 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         40 my @unknown_keys = grep {my $k = $_; not grep {$_ eq $k} @known_setup;} (keys %{$self->{setup}});
  99         155  
  99         142  
  1485         2309  
  19         100  
44 19 50       82 print STDERR "WARNING: Text::NumericData::App got unknown setup keys (@unknown_keys)\n" if @unknown_keys;
45              
46 19 100       78 if($self->{setup}{pipemode})
47             {
48             # Activate pipe processing only on request.
49 13         5618 require Text::ASCIIPipe;
50             }
51              
52 19 50       14965 $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       90 unless defined $self->{setup}{parconf}{version};
61             $self->{setup}{parconf}{author} = $Text::NumericData::author
62 19 50       81 unless defined $self->{setup}{parconf}{author};
63              
64 19 100       89 $self->{setup}{pardef} = [] unless defined $self->{setup}{pardef};
65 19         157 my $prob = Config::Param::sane_pardef($self->{setup}{parconf}, $self->{setup}{pardef});
66 19 50       7035 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       167 $self->add_param('Text::NumericData'
73             , \%Text::NumericData::defaults, \%Text::NumericData::help)
74             or return undef;
75 19 50       99 $self->add_param('Text::NumericData::File'
76             , \%Text::NumericData::File::defaults, \%Text::NumericData::File::help)
77             or return undef;
78              
79 19         130 return $self;
80             }
81              
82             sub add_param
83             {
84 38     38 0 87 my $self = shift;
85 38         102 my ($pkgname, $defaults, $help) = @_;
86 38         73 for my $pn (keys %{$defaults})
  38         191  
87             {
88 270 50 33     637 next if (defined $self->{setup}{exclude} and grep {$_ eq $pn} @{$self->{setup}{exclude}});
  0         0  
  0         0  
89 270         575 my $help = $help->{$pn};
90 270 50       488 $help = "some $pkgname parameter" unless defined $help;
91 270         680 $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         962 , value=>$defaults->{$pn}
98             , help=>$help
99             };
100 270 50       711 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         15754 push(@{$self->{setup}{pardef}}, $thisdef);
  270         673  
106             }
107 38         145 return 1;
108             }
109              
110             sub run
111             {
112 46     46 1 47551 my ($self, $argv, $in, $out) = @_;
113 46 50       171 $argv = \@ARGV unless defined $argv;
114 46 100       142 $in = \*STDIN unless defined $in;
115 46 50       133 $out = \*STDOUT unless defined $out;
116 46         121 binmode $in;
117 46         131 binmode $out;
118 46         120 $self->{argv} = $argv;
119 46         111 $self->{in} = $in;
120 46         112 $self->{out} = $out;
121              
122 46         84 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 46         6607 , $self->{argv}, $errors );
130              
131 46 50       351251 if(@{$errors})
  46         188  
132             {
133 0         0 print STDERR "Stopping here because of parameter parsing errors.\n";
134 0         0 return 1;
135             }
136 46 50 33     309 return 0 if($self->{param}{help} or $self->{param}{version});
137              
138 46 100       145 if($self->{setup}{pipemode})
139             {
140 39 100       137 if(defined $self->{setup}{pipe_init})
141             {
142 35         132 my $err = $self->{setup}{pipe_init}->($self);
143 35 50       102 if($err)
144             {
145 0         0 print STDERR "Pipe init handler failed, aborting.\n";
146 0         0 return $err;
147             }
148             }
149 39 100       118 if($self->{setup}{filemode})
150             {
151             # Not wholly sure about that logic, have to really test and then delete this comment.
152 11         17 while(1)
153             {
154 11         66 $self->new_txd();
155 11         57 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       62 last if $ret <= 0;
159             }
160             $self->{setup}{pipe_allend}->($self)
161 11 50       47 if defined $self->{setup}{pipe_allend};
162             Text::ASCIIPipe::done($self->{out})
163 11 50       40 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 28 50       287 );
    100          
178             }
179 39         1356 return 0;
180             }
181             else
182             {
183 7         48 $self->new_txd();
184 7         30 return $self->main();
185             }
186             }
187              
188             sub new_txd
189             {
190 44     44 1 85 my $self = shift;
191 44 100       2695 require Text::NumericData::File if $self->{setup}{filemode};
192              
193             $self->{txd} = $self->{setup}{filemode}
194             ? Text::NumericData::File->new($self->{param})
195 44 100       329 : Text::NumericData->new($self->{param});
196              
197 44         145 $self->{state}{data} = 0;
198             }
199              
200              
201             sub default_line_hook
202             {
203 492     492 1 13294 my $self = shift;
204 492         779 my $prefix = undef;
205 492 100       1179 if(!$self->{state}{data})
206             {
207 42 100       136 if($self->{txd}->line_check($_[0]))
208             {
209 18         47 $self->{state}{data} = 1;
210             $prefix = $self->{setup}{pipe_first_data}->($self, @_)
211 18 100       87 if defined $self->{setup}{pipe_first_data};
212             }
213             else
214             {
215             $self->{setup}{pipe_header}->($self, @_)
216 24 50       137 if defined $self->{setup}{pipe_header};
217 24         53 return;
218             }
219             }
220             # If still here, $self->{state}{data} == 1 is implied.
221             $self->{setup}{pipe_data}->($self, @_)
222 468 50       1721 if defined $self->{setup}{pipe_data};
223 468 100       1379 $_[0] = ${$prefix}.$_[0]
  7         24  
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__