File Coverage

blib/lib/HTML/Perlinfo/Base.pm
Criterion Covered Total %
statement 15 157 9.5
branch 0 104 0.0
condition 0 51 0.0
subroutine 5 16 31.2
pod 0 11 0.0
total 20 339 5.9


line stmt bran cond sub pod time code
1             package HTML::Perlinfo::Base;
2              
3              
4 1     1   6 use HTML::Perlinfo::Common;
  1         1  
  1         111  
5 1     1   342 use HTML::Perlinfo::General;
  1         1  
  1         60  
6 1     1   6 use Carp ();
  1         1  
  1         12  
7 1     1   3 use warnings;
  1         1  
  1         34  
8 1     1   6 use strict;
  1         1  
  1         1217  
9              
10             sub new {
11 0     0 0   my ($class, %params) = @_;
12 0           my $self = {};
13 0           $self->{full_page} = 1;
14 0           $self->{title} = 0;
15 0           $self->{bg_image} = '';
16 0           $self->{bg_position} = 'center';
17 0           $self->{bg_repeat} = 'no_repeat';
18 0           $self->{bg_attribute} = 'fixed';
19 0           $self->{bg_color} = '#ffffff';
20 0           $self->{ft_family} = 'sans-serif';
21 0           $self->{ft_color} = '#000000';
22 0           $self->{lk_color} = '#000099';
23 0           $self->{lk_decoration} = 'none';
24 0           $self->{lk_bgcolor} = '';
25 0           $self->{lk_hvdecoration} = 'underline';
26 0           $self->{header_bgcolor} = '#9999cc';
27 0           $self->{header_ftcolor} = '#000000';
28 0           $self->{leftcol_bgcolor} = '#ccccff';
29 0           $self->{leftcol_ftcolor} = '#000000';
30 0           $self->{rightcol_bgcolor} = '#cccccc';
31 0           $self->{rightcol_ftcolor} = '#000000';
32              
33 0           foreach my $key (keys %params) {
34 0 0         if (exists $self->{$key}) {
35 0           $self->{$key} = $params{$key};
36             }
37             else {
38 0           error_msg("$key is an invalid attribute");
39             }
40             }
41              
42 0           bless $self, $class;
43 0           return $self;
44            
45             }
46              
47             sub info_all {
48 0     0 0   my $self = shift;
49 0           my %param = @_;
50 0 0 0       error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
      0        
51 0 0         $self->links(@{$param{'links'}}) if exists $param{'links'};
  0            
52 0           my $html;
53 0 0         $self->{title} = 'perlinfo(INFO_ALL)' unless $self->{title};
54 0 0         $html .= $self->print_htmlhead() if $self->{full_page};
55 0           $html .= print_general();
56 0           $html .= print_variables();
57 0           $html .= print_thesemodules('core');
58 0           $html .= print_license();
59 0 0         $html .= "" if $self->{full_page};
60 0 0         defined wantarray ? return $html : print $html;
61             }
62             sub info_general {
63 0     0 0   my $self = shift;
64 0           my %param = @_;
65 0 0 0       error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
      0        
66 0 0         $self->links(@{$param{'links'}}) if exists $param{'links'};
  0            
67 0           my $html;
68 0 0         $self->{title} = 'perlinfo(INFO_GENERAL)' unless $self->{title};
69 0 0         $html .= $self->print_htmlhead() if $self->{full_page};
70 0           $html .= print_general('top');
71 0 0         $html .= "" if $self->{full_page};
72 0 0         defined wantarray ? return $html : print $html;
73             }
74              
75             sub info_loaded {
76              
77 0     0 0   my $self = shift;
78 0 0         $self->{'title'} = 'perlinfo(INFO_LOADED)' unless $self->{'title'};
79 0           my $html;
80 0 0         $html .= $self->print_htmlhead() if $self->{'full_page'};
81              
82 0           eval qq{
83              
84             END {
85             delete \$INC{'HTML/Perlinfo.pm'};
86             \$html .= print_thesemodules('loaded',[values %INC]);
87             \$html .= print_variables();
88             \$html .= '' if \$self->{'full_page'};
89             print \$html;
90             }
91              
92 0 0         }; die $@ if $@;
93              
94             }
95              
96             sub info_modules {
97 0     0 0   my $self = shift;
98 0           my %param = @_;
99 0 0 0       error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
      0        
100 0 0         $self->links(@{$param{'links'}}) if exists $param{'links'};
  0            
101 0           my $html;
102 0 0         $self->{title} = 'perlinfo(INFO_MODULES)' unless $self->{title};
103 0 0         $html .= $self->print_htmlhead() if $self->{'full_page'};
104 0           $html .= print_thesemodules('all');
105 0 0         $html .= "" if $self->{'full_page'};
106 0 0         defined wantarray ? return $html : print $html;
107             }
108             sub info_config {
109 0     0 0   my $self = shift;
110 0           my %param = @_;
111 0 0 0       error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
      0        
112 0 0         $self->links(@{$param{'links'}}) if exists $param{'links'};
  0            
113 0           my $html;
114 0 0         $self->{title} = 'perlinfo(INFO_CONFIG)' unless $self->{title};
115 0 0         $html .= $self->print_htmlhead() if $self->{full_page};
116 0           $html .= print_config('info_config');
117 0 0         $html .= "" if $self->{full_page};
118 0 0         defined wantarray ? return $html : print $html;
119             }
120             sub info_apache {
121 0     0 0   my $self = shift;
122 0           my %param = @_;
123 0 0 0       error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
      0        
124 0 0         $self->links(@{$param{'links'}}) if exists $param{'links'};
  0            
125 0           my $html;
126 0 0         $self->{title} = 'perlinfo(INFO_APACHE)' unless $self->{title};
127 0 0         $html .= $self->print_htmlhead() if $self->{full_page};
128 0           $html .= print_httpd();
129 0 0         $html .= "" if $self->{full_page};
130 0 0         defined wantarray ? return $html : print $html;
131             }
132             sub info_variables {
133 0     0 0   my $self = shift;
134 0           my %param = @_;
135 0 0 0       error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
      0        
136 0 0         $self->links(@{$param{'links'}}) if exists $param{'links'};
  0            
137 0           my $html;
138 0 0         $self->{title} = 'perlinfo(INFO_VARIABLES)' unless $self->{title};
139 0 0         $html .= $self->print_htmlhead() if $self->{full_page};
140 0           $html .= print_variables();
141 0 0         $html .= "" if $self->{full_page};
142 0 0         defined wantarray ? return $html : print $html;
143             }
144              
145             sub info_license {
146 0     0 0   my $self = shift;
147 0           my %param = @_;
148 0 0 0       error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
      0        
149 0 0         $self->links(@{$param{'links'}}) if exists $param{'links'};
  0            
150 0           my $html;
151 0 0         $self->{title} = 'perlinfo(INFO_LICENSE)' unless $self->{title};
152 0 0         $html .= $self->print_htmlhead() if $self->{full_page};
153 0           $html .= print_license();
154 0 0         $html .= "" if $self->{full_page};
155 0 0         defined wantarray ? return $html : print $html;
156             }
157              
158              
159             sub print_htmlhead {
160            
161 0     0 0   my $self = shift;
162              
163 0           my $title = $self->{title};
164 0           my $bg_image = $self->{bg_image};
165 0           my $bg_position = $self->{bg_position};
166 0           my $bg_repeat = $self->{bg_repeat};
167 0           my $bg_attribute = $self->{bg_attribute};
168 0           my $bg_color = $self->{bg_color};
169              
170 0           my $ft_family = $self->{ft_family};
171 0           my $ft_color = $self->{ft_color};
172 0           my $lk_color = $self->{lk_color};
173 0           my $lk_decoration = $self->{lk_decoration};
174 0           my $lk_bgcolor = $self->{lk_bgcolor};
175 0           my $lk_hvdecoration = $self->{lk_hvdecoration};
176              
177 0           my $header_bgcolor = $self->{header_bgcolor};
178 0           my $header_ftcolor = $self->{header_ftcolor};
179 0           my $leftcol_bgcolor =$self->{leftcol_bgcolor};
180 0           my $leftcol_ftcolor = $self->{leftcol_ftcolor};
181 0           my $rightcol_bgcolor = $self->{rightcol_bgcolor};
182 0           my $rightcol_ftcolor = $self->{rightcol_ftcolor};
183              
184 0           my $html = <<"END_OF_HTML";
185            
186            
187             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
188            
189            
190            
220             $title
221            
222            
223             END_OF_HTML
224              
225 0 0         defined wantarray ? return $html : print $html;
226             }
227              
228             sub links {
229              
230 0     0 0   my $self = shift;
231 0           my $args = process_args(@_, \&check_args);
232 0 0 0       if (exists $args->{'0'}) {
    0 0        
    0 0        
    0          
    0          
233 0           $HTML::Perlinfo::Common::links{'all'} = 0;
234             }
235             elsif (exists $args->{'1'}) {
236 0           $HTML::Perlinfo::Common::links{'all'} = 1;
237             }
238             elsif (exists $args->{'docs'} && not exists $args->{'local'}) {
239 0           $HTML::Perlinfo::Common::links{'docs'} = $args->{'docs'};
240             }
241             elsif (exists $args->{'local'} && not exists $args->{'docs'}) {
242 0           $HTML::Perlinfo::Common::links{'local'} = $args->{'local'};
243             }
244             elsif (exists $args->{'docs'} && exists $args->{'local'}) {
245 0           $HTML::Perlinfo::Common::links{'docs'} = $args->{'docs'},
246             $HTML::Perlinfo::Common::links{'local'} = $args->{'local'},
247             }
248             }
249             1;