1package HTML::Perlinfo::Common; 2use strict; 3use warnings; 4 5our @ISA = qw(Exporter); 6our @EXPORT = qw(initialize_globals print_table_colspan_header print_table_row print_table_color_start print_table_color_end print_color_box print_table_row_color print_table_start print_table_end print_box_start print_box_end print_hr print_table_header print_section print_license add_link check_path check_args check_module_args perl_version release_date process_args error_msg match_string); 7require Exporter; 8 9use Carp (); 10 11our %links; 12 13%links = ( 14 'all' => 1, 15 'local' => 0, 16 'docs' => 1, 17); 18 19 20##### The following is lifted from File::Which 0.05 by Per Einar Ellefsen. 21##### The check_path sub uses the which sub. 22############# 23use File::Spec; 24 25my $Is_VMS = ($^O eq 'VMS'); 26my $Is_MacOS = ($^O eq 'MacOS'); 27my $Is_DOSish = (($^O eq 'MSWin32') or 28 ($^O eq 'dos') or 29 ($^O eq 'os2')); 30 31# For Win32 systems, stores the extensions used for 32# executable files 33# For others, the empty string is used 34# because 'perl' . '' eq 'perl' => easier 35my @path_ext = (''); 36if ($Is_DOSish) { 37 if ($ENV{PATHEXT} and $Is_DOSish) { # WinNT. PATHEXT might be set on Cygwin, but not used. 38 push @path_ext, split ';', $ENV{PATHEXT}; 39 } 40 else { 41 push @path_ext, qw(.com .exe .bat); # Win9X or other: doesn't have PATHEXT, so needs hardcoded. 42 } 43} 44elsif ($Is_VMS) { 45 push @path_ext, qw(.exe .com); 46} 47 48sub which { 49 my ($exec) = @_; 50 51 return undef unless $exec; 52 53 my $all = wantarray; 54 my @results = (); 55 56 # check for aliases first 57 if ($Is_VMS) { 58 my $symbol = `SHOW SYMBOL $exec`; 59 chomp($symbol); 60 if (!$?) { 61 return $symbol unless $all; 62 push @results, $symbol; 63 } 64 } 65 if ($Is_MacOS) { 66 my @aliases = split /\,/, $ENV{Aliases}; 67 foreach my $alias (@aliases) { 68 # This has not been tested!! 69 # PPT which says MPW-Perl cannot resolve `Alias $alias`, 70 # let's just hope it's fixed 71 if (lc($alias) eq lc($exec)) { 72 chomp(my $file = `Alias $alias`); 73 last unless $file; # if it failed, just go on the normal way 74 return $file unless $all; 75 push @results, $file; 76 # we can stop this loop as if it finds more aliases matching, 77 # it'll just be the same result anyway 78 last; 79 } 80 } 81 } 82 83 my @path = File::Spec->path(); 84 unshift @path, File::Spec->curdir if $Is_DOSish or $Is_VMS or $Is_MacOS; 85 86 for my $base (map { File::Spec->catfile($_, $exec) } @path) { 87 for my $ext (@path_ext) { 88 my $file = $base.$ext; 89 90 if ((-x $file or # executable, normal case 91 ($Is_MacOS || # MacOS doesn't mark as executable so we check -e 92 ($Is_DOSish and grep { $file =~ /$_$/i } @path_ext[1..$#path_ext]) 93 # DOSish systems don't pass -x on non-exe/bat/com files. 94 # so we check -e. However, we don't want to pass -e on files 95 # that aren't in PATHEXT, like README. 96 and -e _) 97 ) and !-d _) 98 { # and finally, we don't want dirs to pass (as they are -x) 99 100 101 return $file unless $all; 102 push @results, $file; # Make list to return later 103 } 104 } 105 } 106 107 if($all) { 108 return @results; 109 } else { 110 return undef; 111 } 112} 113 114## End File::Which code 115 116sub check_path { 117 118 return add_link('local', which("$_[0]")) if which("$_[0]"); 119 return "<i>not in path</i>"; 120 121} 122 123sub match_string { 124 my($module_name, $string) = @_; 125 126 my $result = 0; 127 my @string = (ref $string eq 'ARRAY') ? @$string : ($string); 128 foreach(@string) { 129 $result = index(lc($module_name), lc($_)); 130 last if ($result != -1); 131 } 132 return ($result == -1) ? 0 : 1; 133 134} 135 136sub perl_version { 137 my $version; 138 if ($] >= 5.006) { 139 $version = sprintf "%vd", $^V; 140 } 141 else { # else time to update Perl! 142 $version = "$]"; 143 } 144 return $version; 145} 146 147sub release_date { 148 149# when things escaped 150 my %released = ( 151 5.000 => '1994-10-17', 152 5.001 => '1995-03-14', 153 5.002 => '1996-02-96', 154 5.00307 => '1996-10-10', 155 5.004 => '1997-05-15', 156 5.005 => '1998-07-22', 157 5.00503 => '1999-03-28', 158 5.00405 => '1999-04-29', 159 5.006 => '2000-03-22', 160 5.006001 => '2001-04-08', 161 5.007003 => '2002-03-05', 162 5.008 => '2002-07-19', 163 5.008001 => '2003-09-25', 164 5.009 => '2003-10-27', 165 5.008002 => '2003-11-05', 166 5.006002 => '2003-11-15', 167 5.008003 => '2004-01-14', 168 5.00504 => '2004-02-23', 169 5.009001 => '2004-03-16', 170 5.008004 => '2004-04-21', 171 5.008005 => '2004-07-19', 172 5.008006 => '2004-11-27', 173 5.009002 => '2005-04-01', 174 5.008007 => '2005-05-30', 175 5.009003 => '2006-01-28', 176 5.008008 => '2006-01-31', 177 5.009004 => '2006-08-15', 178 5.009005 => '2007-07-07', 179 5.010000 => '2007-12-18', 180 ); 181 182 # Do we have Module::Corelist 183 eval{require Module::CoreList}; 184 if ($@) { # no 185 return ($released{$]}) ? $released{$]} : "unknown"; 186 } 187 else { # yes 188 return ($Module::CoreList::released{$]}) ? $Module::CoreList::released{$]} : "unknown"; 189 } 190 191} 192 193sub check_args { 194 195 my ($key, $value) = @_; 196 my ($message, %allowed); 197 @allowed{qw(docs local 0 1)} = (); 198 199 if (not exists $allowed{$key}) { 200 $message = "$key is an invalid links parameter"; 201 } 202 elsif ($key =~ /(?:docs|local)/ && $value !~ /^(?:0|1)$/i) { 203 $message = "$value is an invalid value for the $key parameter in the links attribute"; 204 } 205 206 error_msg("$message") if $message; 207 208} 209 210sub check_module_args { 211 212 my ($key, $value) = @_; 213 my ($message, %allowed); 214 @allowed{qw(from columns sort_by color link show_only section full_page show_inc show_dir files_in)} = (); 215 216 if (not exists $allowed{$key}) { 217 $message = "$key is an invalid print_modules parameter"; 218 } 219 elsif ($key eq 'sort_by' && $value !~ /^(?:name|version)$/i) { 220 $message = "$value is an invalid sort"; 221 } 222 elsif ($key =~ /^(?:color|link|columns|files_in)$/ && ref($value) ne 'ARRAY') { 223 $message = "The $key parameter value is not an array reference"; 224 } 225 elsif ($key eq 'columns' && grep(!/^(?:name|version|desc|path|core)$/, @{$value})) { 226 $message = "Invalid column name in the $key parameter"; 227 } 228 elsif ($key eq 'color' && @{$value} <= 1) { 229 $message = "You didn't specify a module to color"; 230 } 231 elsif ($key eq 'link' && @{$value} <= 1 && $value->[0] != 0) { 232 $message = "You didn't provide a URL for the $key parameter"; 233 } 234 elsif ($key eq 'show_only' && (ref($value) ne 'ARRAY') && lc $value ne 'core') { 235 $message = "$value is an invalid value for the $key parameter"; 236 } 237 elsif ($key eq 'full_page' && $value != 0 && $value != 1 ) { 238 $message = "$value is an invalid value for the $key parameter"; 239 } 240 elsif ($key eq 'link' && ($value->[0] ne 'all' && $value->[0] != 0 && ref($value->[0]) ne 'ARRAY')) { 241 $message = "Invalid first element in the $key parameter value"; 242 } 243 error_msg("$message") if $message; 244} 245 246 247 248sub process_args { 249 # This sub returns a hash ref containing param args 250 my %params; 251 my $sub = pop @_ || die "No coderef provided\n"; # get the sub 252 if (defined $_[0]) { 253 while(my($key, $value) = splice @_, 0, 2) { 254 $sub->($key, $value); 255 if (exists $params{$key}){ 256 my @key_value = ref(${$params{$key}}[0]) eq 'ARRAY' ? @{$params{$key}} : $params{$key}; 257 push @key_value,$value; 258 my $new_val = [@key_value]; 259 $params{$key} = $new_val; 260 } 261 else { 262 $params{$key} = $value; 263 } 264 } 265 } 266 return \%params; 267} 268 269sub error_msg { 270 local $Carp::CarpLevel = $Carp::CarpLevel + 1; 271 Carp::croak "User error: $_[0]"; 272} 273 274# HTML subs 275 276sub print_table_colspan_header { 277 278 return sprintf("<tr class=\"h\"><th colspan=\"%d\">%s</th></tr>\n", $_[0], $_[1]); 279 280 } 281 282 sub print_table_row { 283 284 285 my $num_cols = $_[0]; 286 my $HTML = "<tr>"; 287 288 for (my $i=0; $i<$num_cols; $i++) { 289 290 $HTML .= sprintf("<td class=\"%s\">", ($i==0 ? "e" : "v" )); 291 292 my $row_element = $_[$i+1]; 293 if ((not defined ($row_element)) || ($row_element !~ /\S/)) { 294 $HTML .= "<i>no value</i>"; 295 } else { 296 my $elem_esc = $row_element; 297 $HTML .= "$elem_esc"; 298 299 } 300 301 $HTML .= " </td>"; 302 303 } 304 305 $HTML .= "</tr>\n"; 306 return $HTML; 307 308 } 309 310 311 sub print_table_color_start { 312 313 return qq~<table class="modules" cellpadding=4 cellspacing=4 border=0 width="600"><tr>\n~; 314 } 315 316 sub print_table_color_end { 317 318 return '</tr></table>'; 319 } 320 321 322 sub print_color_box { 323 324 return qq ~<td> 325 <table border=0> 326 <tr><td> 327 <table class="modules" border=0 width=50 height=50 align=left bgcolor="$_[0]"> 328 <tr bgcolor="$_[0]"> 329 <td color="$_[0]"> 330 331 </td> 332 </tr> 333 </table> 334 </tr></td> 335 <tr><td><small>$_[1]</small></td></tr> 336 </table> 337 </td>~; 338 } 339 340 sub print_table_row_color { 341 342 my $num_cols = $_[0]; 343 my $HTML = $_[1] ? "<tr bgcolor=\"$_[1]\">" : "<tr>"; 344 345 for (my $i=0; $i<$num_cols; $i++) { 346 347 $HTML .= $_[1] ? "<td bgcolor=\"$_[1]\">" : sprintf("<td class=\"%s\">", ($i==0 ? "e" : "v" )); 348 349 my $row_element = $_[$i+2]; # start at the 2nd element 350 if ((not defined ($row_element)) || ($row_element !~ /\S/)) { 351 $HTML .= "<i>no value</i>"; 352 } else { 353 my $elem_esc = $row_element; 354 $HTML .= "$elem_esc"; 355 356 } 357 358 $HTML .= " </td>"; 359 360 } 361 362 $HTML .= "</tr>\n"; 363 return $HTML; 364 } 365 366 sub print_table_start { 367 368 return "<table border=\"0\" cellpadding=\"3\" width=\"600\">\n"; 369 370 } 371 sub print_table_end { 372 373 return "</table><br />\n"; 374 375 } 376 sub print_box_start { 377 378 my $HTML = print_table_start(); 379 $HTML .= ($_[0] == 1) ? "<tr class=\"h\"><td>\n" : "<tr class=\"v\"><td>\n"; 380 return $HTML; 381 } 382 383 384 sub print_box_end { 385 my $HTML = "</td></tr>\n"; 386 $HTML .= print_table_end(); 387 return $HTML; 388 } 389 390 sub print_hr { 391 return "<hr />\n"; 392 393 } 394 395 396 sub print_table_header { 397 398 my($num_cols) = $_[0]; 399 my $HTML = "<tr class=\"h\">"; 400 401 my $i; 402 for ($i=0; $i<$num_cols; $i++) { 403 my $row_element = $_[$i+1]; 404 $row_element = " " if (!$row_element); 405 $HTML .= "<th>$row_element</th>"; 406 } 407 408 return "$HTML</tr>\n"; 409 } 410 411 412 sub print_section { 413 414 return "<h2>" . $_[0] . "</h2>\n"; 415 416 } 417 418 419 420 sub print_perl_license { 421 422 return <<"END_OF_HTML"; 423<p> 424This program is free software; you can redistribute it and/or modify it under the terms of 425either the Artistic License or the GNU General Public License, which may be found in the Perl 5 source kit. 426</p> 427 428<p> 429This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 430</p> 431<p> 432Complete documentation for Perl, including FAQ lists, should be found on 433this system using `man perl' or `perldoc perl'. If you have access to the 434Internet, point your browser at @{[ add_link('same', 'http://www.perl.org/')]}, the Perl directory. 435</p> 436END_OF_HTML 437 438 } 439 440sub print_license { 441 442 return join '', print_section("Perl License"), 443 print_box_start(0), 444 print_perl_license(), 445 print_box_end(); 446} 447 448 449sub add_link { 450 451 my ($type, $value, $link) = @_; 452 return $value unless $links{'all'}; 453 454 if ($type eq "cpan") { 455 456 return $value if $link && $link->[0] =~ /^[0]$/; 457 458 if ($link) { 459 if (ref $link->[0] eq 'ARRAY' && ref $link->[1] ne 'ARRAY') { 460 foreach (@{$link->[0]}) { 461 if ($_ eq 'all' or match_string($value,$_)==1) { 462 return '<a href=' . $link->[1] . $value . 463 qq~ title="Click here to see $value documentation [Opens in a new window]" 464 target="_blank">$value</a> ~ 465 } 466 } 467 } 468 elsif (ref $link->[0] eq 'ARRAY' && ref $link->[1] eq 'ARRAY'){ 469 foreach my $lv (@$link) { 470 if (ref $lv->[0] eq 'ARRAY') { 471 foreach(@{$lv->[0]}) { 472 if ($_ eq 'all' or match_string($value,$_)==1) { 473 return '<a href=' . $lv->[1] . $value . 474 qq~ title="Click here to see $value documentation [Opens in a new window]" 475 target="_blank">$value</a> ~ 476 } 477 } 478 } 479 else { 480 if ($lv->[0] eq 'all' or match_string($value,$lv->[0])==1) { 481 return '<a href=' . $lv->[1] . $value . 482 qq~ title="Click here to see $value documentation [Opens in a new window]" 483 target="_blank">$value</a> ~ 484 } 485 } 486 } 487 } 488 elsif ($link->[0] eq 'all' or match_string($value,$link->[0])==1) { 489 return '<a href=' . $link->[1] . $value . 490 qq~ title="Click here to see $value documentation [Opens in a new window]" 491 target="_blank">$value</a> ~ 492 } 493 } 494 return qq~ <a href="http://search.cpan.org/perldoc?$value" 495 title="Click here to see $value on CPAN [Opens in a new window]" target="_blank">$value</a> ~; 496 } 497 elsif ($type eq "config") { 498 return $value unless $links{'docs'}; 499 my ($letter) = $value =~ /^(.)/; 500 return qq! <a href="http://search.cpan.org/~aburlison/Solaris-PerlGcc-1.3/config/5.006001/5.10/sparc/Config.pm#$letter">$value</a> !; 501 } 502 elsif ($type eq "local") { 503 return $value unless $links{'local'}; 504 return qq~ <a href="file://$value" title="Click here to see $value [Opens in a new window]" target="_blank">$value</a> ~; 505 } 506 elsif ($type eq "same") { 507 return qq~ <a href="$value">$value</a> ~; 508 } 509} 510 5111; 512