File Coverage

blib/lib/HTML/Perlinfo/Base.pm
Criterion Covered Total %
statement 15 166 9.0
branch 0 112 0.0
condition 0 51 0.0
subroutine 5 17 29.4
pod 0 12 0.0
total 20 358 5.5


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