File Coverage

blib/lib/EB/Report/GenBase.pm
Criterion Covered Total %
statement 21 138 15.2
branch 0 74 0.0
condition 0 26 0.0
subroutine 7 15 46.6
pod 0 6 0.0
total 28 259 10.8


line stmt bran cond sub pod time code
1             #! perl -- -*- coding: utf-8 -*-
2              
3 1     1   3 use utf8;
  1         1  
  1         42  
4              
5             # Author : Johan Vromans
6             # Created On : Sat Oct 8 16:40:43 2005
7             # Last Modified By: Johan Vromans
8             # Last Modified On: Mon Jan 16 15:56:26 2012
9             # Update Count : 176
10             # Status : Unknown, Use with caution!
11              
12             package main;
13              
14             our $cfg;
15             our $dbh;
16              
17             package EB::Report::GenBase;
18              
19 1     1   44 use strict;
  1         1  
  1         15  
20 1     1   3 use EB;
  1         1  
  1         144  
21              
22 1     1   444 use IO::File;
  1         1417  
  1         82  
23 1     1   4 use EB::Format;
  1         1  
  1         90  
24 1     1   4 use File::Glob qw(:glob); # glob that allows space (for Windows);
  1         1  
  1         1377  
25              
26             sub new {
27 0     0 0   my ($class, $opts) = @_;
28 0   0       $class = ref($class) || $class;
29 0           my $self = { %$opts };
30 0           bless $self => $class;
31             }
32              
33             # API.
34 0     0     sub _oops { warn("?Package ".ref($_[0])." did not implement '$_[1]' method\n") }
35 0     0 0   sub start { shift->_oops('start') }
36 0     0 0   sub outline { shift->_oops('outline') }
37 0     0 0   sub finish { shift->_oops('finish') }
38              
39             # Class methods
40              
41             sub backend {
42 0     0 0   my (undef, $self, $opts) = @_;
43              
44 0           my %extmap = ( txt => "text", htm => "html" );
45              
46 0           my $gen;
47              
48             # Short options, like --html.
49 0           for ( qw(html csv text) ) {
50 0 0         $gen = $_ if $opts->{$_};
51             }
52              
53             # Override by explicit --gen-XXX option(s).
54 0           foreach ( keys(%$opts) ) {
55 0 0         next unless /^gen-(.*)$/;
56 0           $gen = $1;
57             }
58              
59             # Override by explicit --generate option(s).
60 0 0         $gen = $opts->{generate} if $opts->{generate};
61              
62             # Infer from filename extension.
63 0           my $t;
64 0 0 0       if ( !defined($gen) && ($t = $opts->{output}) && $t =~ /\.([^.]+)$/ ) {
      0        
65 0           my $ext = lc($1);
66 0   0       $ext = $extmap{$ext} || $ext;
67 0           $gen = $ext;
68             }
69              
70             # Fallback to text.
71 0   0       $gen ||= "text";
72              
73             # Build class and package name. Last chance to override...
74 0   0       my $class = $opts->{backend} || (ref($self)||$self) . "::" . ucfirst($gen);
75 0           my $pkg = $class;
76 0           $pkg =~ s;::;/;g;;
77 0           $pkg .= ".pm";
78              
79             # Try to load backend. Gives user the opportunity to override.
80             eval {
81 0           local $SIG{__WARN__};
82 0           local $SIG{__DIE__};
83 0           require $pkg;
84 0 0         } unless $ENV{AUTOMATED_TESTING};
85 0 0         if ( ! _loaded($class) ) {
86 0           my $err = $@;
87 0 0         if ( $err =~ /^can't locate /i ) {
88 0           $err = _T("De uitvoer-backend kon niet worden gevonden");
89             }
90 0           die("?".__x("Uitvoer in de vorm {gen} is niet mogelijk: {reason}",
91             gen => $gen, reason => $err)."\n");
92             }
93 0           my $be = $class->new($opts);
94              
95             # Handle output redirection.
96 0 0 0       if ( $opts->{output} && $opts->{output} ne '-' ) {
    0          
97             $be->{fh} = IO::File->new($opts->{output}, "w")
98             or die("?".__x("Fout tijdens aanmaken {file}: {err}",
99 0 0         file => $opts->{output}, err => $!)."\n");
100             }
101             elsif ( fileno(STDOUT) > 0 ) {
102             # Normal file.
103 0           $be->{fh} = IO::File->new_from_fd(fileno(STDOUT), "w");
104             }
105             else {
106             # In-memory.
107 0           $be->{fh} = bless \*STDOUT , 'IO::Handle';
108             }
109 0           binmode($be->{fh}, ":encoding(utf8)");
110              
111             # Handle pagesize.
112 0 0         $be->{fh}->format_lines_per_page($be->{page} = defined($opts->{page}) ? $opts->{page} : 999999);
113              
114             # Get real (or fake) current date, and adjust periode end if needed.
115 0           $be->{now} = iso8601date();
116 0 0         if ( my $t = $cfg->val(qw(internal now), 0) ) {
117 0 0         $be->{now} = $t if $be->{now} gt $t;
118             }
119              
120             # Date/Per.
121 0 0 0       if ( $opts->{per} ) {
    0          
    0          
122 0 0         die(_T("--per sluit --periode uit")."\n") if $opts->{periode};
123 0 0         die(_T("--per sluit --boekjaar uit")."\n") if defined $opts->{boekjaar};
124             $be->{periode} = [ $be->{per_begin} = $dbh->adm("begin"),
125 0           $be->{per_end} = $opts->{per} ];
126 0           $be->{periodex} = 1;
127             }
128             elsif ( $opts->{periode} ) {
129 0 0         die(_T("--periode sluit --boekjaar uit")."\n") if defined $opts->{boekjaar};
130 0           $be->{periode} = $opts->{periode};
131 0           $be->{per_begin} = $opts->{periode}->[0];
132 0           $be->{per_end} = $opts->{periode}->[1];
133 0           $be->{periodex} = 2;
134             }
135             elsif ( defined($opts->{boekjaar}) || defined($opts->{d_boekjaar}) ) {
136 0           my $bky = $opts->{boekjaar};
137 0 0         $bky = $opts->{d_boekjaar} unless defined $bky;
138 0           my $rr = $dbh->do("SELECT bky_begin, bky_end".
139             " FROM Boekjaren".
140             " WHERE bky_code = ?", $bky);
141 0 0         die("?",__x("Onbekend boekjaar: {bky}", bky => $bky)."\n"), return unless $rr;
142 0           my ($begin, $end) = @$rr;
143             $be->{periode} = [ $be->{per_begin} = $begin,
144 0           $be->{per_end} = $end ];
145 0           $be->{periodex} = 3;
146 0           $be->{boekjaar} = $bky;
147             }
148             else {
149             $be->{periode} = [ $be->{per_begin} = $dbh->adm("begin"),
150 0           $be->{per_end} = $dbh->adm("end") ];
151 0           $be->{periodex} = 0;
152             }
153              
154 0 0         if ( $be->{per_end} gt $be->{now} ) {
155             warn("!".__x("Datum {per} valt na de huidige datum {now}",
156             per => datefmt_full($be->{per_end}),
157 0           now => datefmt_full($be->{now}))."\n")
158             if 0;
159             $be->{periode}->[1] = $be->{per_end} = $be->{now}
160 0           if 0;
161             }
162              
163             # Sanity.
164 0           my $opendate = $dbh->do("SELECT min(bky_begin) FROM Boekjaren WHERE NOT bky_code = ?",
165             BKY_PREVIOUS)->[0];
166              
167 0 0         if ( $be->{per_begin} gt $be->{now} ) {
168             die("?".__x("Periode begint {from}, dit is na de huidige datum {now}",
169             from => datefmt_full($be->{per_begin}),
170 0           now => datefmt_full($be->{now}))."\n");
171             }
172 0 0         if ( $be->{per_begin} lt $opendate ) {
173             die("?".__x("Datum {per} valt vóór het begin van de administratie {begin}",
174 0           per => datefmt_full($be->{per_begin}),
175             begin => datefmt_full($opendate))."\n");
176             }
177 0 0         if ( $be->{per_end} lt $opendate ) {
178             die("?".__x("Datum {per} valt vóór het begin van de administratie {begin}",
179 0           per => datefmt_full($be->{per_end}),
180             begin => datefmt_full($opendate))."\n");
181             }
182              
183 0           $be->{_cssdir} = $cfg->val(qw(html cssdir), undef);
184 0 0         $be->{_cssdir} =~ s;/*$;/; if defined $be->{_cssdir};
185 0 0         $be->{_style} = $opts->{style} if $opts->{style};
186 0 0         $be->{_title0} = $opts->{title} if $opts->{title};
187              
188             # Return instance.
189 0           $be;
190             }
191              
192             my %bec;
193              
194             sub backend_options {
195 0     0 0   my (undef, $self, $opts) = @_;
196              
197 0   0       my $package = ref($self) || $self;
198 0           my $pkg = $package;
199 0           $pkg =~ s;::;/;g;;
200 0 0         return @{$bec{$pkg}} if $bec{$pkg};
  0            
201              
202             # Some standard backends may be included in the coding ...
203 0           my %be;
204 0           foreach my $std ( qw(text html csv) ) {
205 0 0         $be{$std} = 1 if _loaded($package . "::" . ucfirst($std));
206             }
207              
208             #### FIXME: options dest is uncontrollable!!!!
209             #### DO NOT TRANSLATE UNTIL FIXED !!!!
210              
211 0           my @opts = ( __xt("cmo:report:output")."=s",
212             __xt("cmo:report:page")."=i" );
213              
214 0 0         if ( $Cava::Packager::PACKAGED ) {
215 0           $be{wxhtml}++;
216 0 0         unless ( $be{wxhtml} ) {
217             # Ignored, but forces the packager to include these modules.
218 0           require EB::Report::BTWAangifte::Wxhtml;
219 0           require EB::Report::Balres::Wxhtml;
220 0           require EB::Report::Debcrd::Wxhtml;
221 0           require EB::Report::Grootboek::Wxhtml;
222 0           require EB::Report::Journal::Wxhtml;
223 0           require EB::Report::Open::Wxhtml;
224 0           require EB::Report::Proof::Wxhtml;
225             }
226             }
227             else {
228             # Find files.
229 0           foreach my $lib ( @INC ) {
230 0           my @files = glob("$lib/$pkg/*.pm");
231 0 0         next unless @files;
232             # warn("=> be_opt: found ", scalar(@files), " files in $lib/$pkg\n");
233 0           foreach ( @files ) {
234 0 0         next unless m;/([^/]+)\.pm$;;
235             # Actually, we should check whether the class implements the
236             # GenBase API, but we can't do that without preloading all
237             # backends.
238 0           $be{lc($1)}++;
239             }
240             }
241             }
242              
243             # Short --XXX for known backends.
244 0           foreach ( qw(html csv text) ) {
245 0 0         push(@opts, $_) if $be{$_};
246             }
247             push(@opts,
248             __xt("cmo:report:style")."=s",
249 0 0         __xt("cmo:report:title|titel")."=s") if $be{html};
250              
251             # Explicit --gen-XXX for all backends.
252 0           push(@opts, map { +"gen-$_"} keys %be);
  0            
253             # Cache.
254 0           $bec{$pkg} = [@opts];
255              
256 0           @opts; # better be list context
257             }
258              
259             # Helper.
260              
261             sub _loaded {
262 0     0     my $class = shift;
263 1     1   4 no strict "refs";
  1         2  
  1         37  
264 0 0         %{$class . "::"} ? 1 : 0;
  0            
265             }
266             1;