File Coverage

blib/lib/EB/Globals.pm
Criterion Covered Total %
statement 28 33 84.8
branch 4 10 40.0
condition 3 3 100.0
subroutine 8 13 61.5
pod 0 6 0.0
total 43 65 66.1


line stmt bran cond sub pod time code
1             #! perl
2              
3             # Globals.pm --
4             # Author : Johan Vromans
5             # Created On : Thu Jul 14 12:54:08 200
6             # Last Modified By: Johan Vromans
7             # Last Modified On: Tue May 29 12:40:13 2012
8             # Update Count : 104
9             # Status : Unknown, Use with caution!
10              
11 6     6   18 use utf8;
  6         11  
  6         21  
12              
13             package EB::Globals;
14              
15 6     6   173 use strict;
  6         6  
  6         93  
16 6     6   22 use warnings;
  6         5  
  6         165  
17              
18 6     6   18 use base qw(Exporter);
  6         5  
  6         2766  
19              
20             our @EXPORT;
21              
22             # Define new constant subroutine, and add it to @EXPORT.
23             sub _newconst($$) {
24 222     222   168 my $t = $_[1];
25 222 100 100     922 $t = "'$t'" unless $t =~ /^\d+$/ || $t =~ /^\[.*\]$/;
26             #warn("sub $_[0](){$t}\n");
27 222     0 0 5569 eval("sub $_[0](){$t}");
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0         0  
28 222         560 push(@EXPORT, $_[0]);
29             }
30              
31             # Define an enumeration of constant subroutines.
32             sub _enumconst($@) {
33 18     18   30 my ($pfx, @list) = @_;
34 18         18 my $index = 0;
35 18         24 foreach ( @list ) {
36 84         110 my $key = $pfx.$_;
37 84 100       189 if ( $key =~ /^(.*)=(\d+)$/ ) {
38 18         33 $key = $1;
39 18         22 $index = $2;
40             }
41 84         139 _newconst( $key, $index++ );
42             }
43             }
44              
45             # To defeat gettext. Strings here are not for translation.
46 24     24 0 131 sub N__($) { $_[0] }
47              
48             _newconst("SCM_MAJVERSION", 1);
49             _newconst("SCM_MINVERSION", 0);
50             _newconst("SCM_REVISION", 16);
51              
52             _newconst("AMTPRECISION", 2);
53             _newconst("AMTWIDTH", 9);
54             _newconst("NUMGROUPS", 3);
55             _newconst("BTWPRECISION", 4);
56             _newconst("BTWWIDTH", 5);
57             _newconst("AMTSCALE", 100);
58             _newconst("BTWSCALE", 10000);
59              
60             _newconst("BKY_PREVIOUS", "<<<<");
61              
62             _enumconst("DBKTYPE_", qw(INKOOP=1 VERKOOP BANK KAS MEMORIAAL) );
63             _newconst("DBKTYPES",
64             "[qw(".N__("-- Inkoop Verkoop Bank Kas Memoriaal").")]");
65              
66             _enumconst("BTWTARIEF_", qw(NUL=0 HOOG LAAG PRIV ANDERS) );
67             _newconst("BTWTARIEVEN", "[qw(".N__("Nul Hoog Laag PrivĂ© Anders").")]");
68             _newconst("BTWPERIODES", "[qw(".N__("Geen Jaar 2 3 Kwartaal 5 6 7 8 9 10 11 Maand").")]");
69             _newconst("BTWPER_GEEN", 0);
70             _newconst("BTWPER_JAAR", 1);
71             _newconst("BTWPER_KWARTAAL", 4);
72             _newconst("BTWPER_MAAND", 12);
73             _enumconst("BTWTYPE_", qw(NORMAAL=0 VERLEGD INTRA EXTRA) );
74             _newconst("BTWTYPES", "[qw(".N__("Normaal Verlegd Intra Extra").")]");
75             _newconst("BTWKLASSE_BTW_BIT", 0x200);
76             _newconst("BTWKLASSE_KO_BIT", 0x100);
77             _newconst("BTWKLASSE_TYPE_BITS", 0x0ff);
78              
79             # Starting value for automatically defined BTW codes.
80             _newconst("BTW_CODE_AUTO", 1024);
81              
82             # Eval, since it uses the (run-time defined) subroutines.
83 0 0   0 0   eval( 'sub BTWKLASSE($$$) {'.
    0          
    0          
84             ' ($_[0] ? BTWKLASSE_BTW_BIT : 0)'.
85             ' | ($_[1] ? ($_[1] & BTWKLASSE_TYPE_BITS) : 0)'.
86             ' | ($_[2] ? BTWKLASSE_KO_BIT : 0);'.
87             '}' );
88             push(@EXPORT, qw(BTWKLASSE));
89              
90             unless ( caller ) {
91             print STDOUT ("-- Constants\n\n",
92             "COMMENT ON TABLE Constants IS\n",
93             " 'This is generated from ", __PACKAGE__, ". DO NOT CHANGE.';\n\n",
94             "COPY Constants (name, value) FROM stdin;\n");
95              
96             foreach my $key ( sort(@EXPORT) ) {
97 6     6   22 no strict;
  6         6  
  6         428  
98             next if ref($key->());
99             print STDOUT ("$key\t", $key->(), "\n");
100             }
101             print STDOUT ("\\.\n");
102             }
103              
104             1;