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				 &nbsp;
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