File Coverage

blib/lib/Theodor/Wagner.pm
Criterion Covered Total %
statement 9 56 16.0
branch 0 26 0.0
condition 0 30 0.0
subroutine 3 7 42.8
pod 0 4 0.0
total 12 123 9.7


line stmt bran cond sub pod time code
1             package Theodor::Wagner;
2              
3 1     1   18309 use 5.006;
  1         3  
  1         43  
4 1     1   5 use strict;
  1         2  
  1         32  
5 1     1   5 use warnings;
  1         7  
  1         1046  
6              
7             require Exporter;
8              
9             our @ISA = qw(Exporter);
10              
11             # Items to export into callers namespace by default. Note: do not export
12             # names by default without a very good reason. Use EXPORT_OK instead.
13             # Do not simply export all your public functions/methods/constants.
14              
15             # This allows declaration use Theodor::Wagner ':all';
16             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
17             # will save memory.
18             our %EXPORT_TAGS = ( 'all' => [ qw(
19            
20             ) ] );
21              
22             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
23              
24             our @EXPORT = qw();
25             our $VERSION = '0.81';
26              
27              
28             my $package = __PACKAGE__;
29              
30             # GLOBAL VARIABLES
31             my %Var = ();
32             my $contentType = "";
33              
34             $| = 1;
35              
36             #----- FORWARD DECLARATIONS & PROTOTYPING
37             sub Error($);
38             sub Debug($);
39              
40             sub new {
41 0     0 0   my $type = shift;
42 0           my %params = @_;
43 0           my $self = {};
44              
45 0           $self->{'file'} = $params{'file'};
46 0           $self->{'debug'} = $params{'debug'};
47              
48 0 0         Debug "$package V$VERSION" if $self->{'debug'};
49              
50 0           bless $self, $type;
51             }
52              
53             sub weekday {
54 0     0 0   my $self = shift;
55 0           my %Params = @_;
56              
57 0           my $yyyy = $Params{Y};
58 0           my $mm = $Params{M};
59 0           my $dd = $Params{D};
60            
61 0           my $cc = substr($yyyy, 0, 2);
62 0           my $yy = substr($yyyy, 2, 2);
63              
64 0           print "$mm/$dd/$yyyy - $cc/$yy\...\n";
65              
66 0           my $mod_dd = $dd % 7;
67              
68 0           print "> $dd (dd) % 7 = $mod_dd\n";
69              
70 0 0 0       if ($mm == 1 or $mm ==2) {
71 0 0 0       if ((($yy % 4) == 0 && ($yy % 100) != 0) or ($yy % 400) == 0) {
      0        
72 0           $mm += 12;
73             }
74             }
75              
76             ##### CALCULATING TABLE 1:
77 0           my $h_month = 0;
78 0 0 0       $h_month = 0 if $mm == 8 or ($mm == 14);
79 0 0 0       $h_month = 1 if $mm == 2 or ($mm == 3) or ($mm == 11);
      0        
80 0 0         $h_month = 2 if $mm == 6;
81 0 0 0       $h_month = 3 if $mm == 9 or ($mm == 12);
82 0 0 0       $h_month = 4 if $mm == 4 or ($mm == 7) or ($mm == 13);
      0        
83 0 0 0       $h_month = 5 if $mm == 1 or ($mm == 10);
84 0 0         $h_month = 6 if $mm == 5;
85              
86 0 0         $mm -= 12 if $mm > 12;
87              
88 0           my $table1 = $mod_dd + $h_month;
89              
90 0           print "> [Table 1] $mod_dd + $h_month (h_month) = $table1\n";
91              
92              
93             ##### CALCULATING TABLE 2:
94 0           my $year2 = ($yy * 1.25) % 7;
95              
96 0           print "> ($yy * 1.25) % 7 = $year2\n";
97              
98 0           my $ccTmp = (($cc - 1) % 4) +1;
99              
100 0           my $century2 = 0;
101              
102 0 0         if ($ccTmp == 4) { $century2 = 2 } else { $century2 = 9 - 2 * $ccTmp }
  0            
  0            
103              
104 0           my $table2 = $century2 + $year2;
105              
106 0           print "> [Table 2] $century2 (century2) + $year2 (year2) = $table2\n";
107              
108 0           my $wd = ($table1 + $table2) % 7;
109              
110 0           my @weekdays = ('Sa', 'So', 'Mo', 'Tu', 'We', 'Th', 'Fr');
111              
112 0           $weekdays[$wd];
113             }
114              
115             sub Error ($) {
116 0 0   0 0   print "Content-type: text/html\n\n" unless $contentType;
117 0           print "ERROR ($package): $_[0]\n";
118 0           exit(1);
119             }
120              
121 0     0 0   sub Debug ($) { print "[ $package ] $_[0]\n" }
122              
123             #### Used Warning / Error Codes ##########################
124             # Next free W Code: 1000
125             # Next free E Code: 1000
126              
127             1;
128             __END__