File Coverage

blib/lib/Web/Scaffold.pm
Criterion Covered Total %
statement 113 483 23.4
branch 32 210 15.2
condition 20 107 18.6
subroutine 13 31 41.9
pod 1 26 3.8
total 179 857 20.8


line stmt bran cond sub pod time code
1             package Web::Scaffold;
2              
3             #use diagnostics;
4 7     7   7394 use strict;
  7         15  
  7         254  
5 7     7   6330 use POSIX;
  7         54741  
  7         54  
6 7     7   20372 use Fcntl qw(:flock);
  7         19  
  7         829  
7 7     7   45 use vars qw($VERSION);
  7         14  
  7         45937  
8              
9             $VERSION = do { my @r = (q$Revision: 0.15 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
10              
11             my @defaults = (
12              
13             # directory path for 'html pages' relative to the html root
14             # i.e. public_html/ defaults to:
15             #
16             pagedir => '../pages',
17              
18             # directory path for 'javascript libraries' relative to html root
19             # defaults to:
20              
21             javascript => 'lib',
22              
23             # no search conditions for building the site map. Each
24             # element is evaluated as a perl match condition in the
25             # context of m/element/. Include page names, extensions, etc...
26             #
27             # [OPTIONAL]
28             #
29              
30             nosearch => [ 'pdf' ],
31              
32             # Directory path for 'sitemap' page generation relative to the
33             # html root. This directory must be WRITABLE by the web server.
34             #
35             # NOTE: link the file 'sitemapdir'/sitemaplxml to the
36             # appropriate location in your web directory.
37             #
38             # The sitemap.xml file will be generated and updated ONLY if
39             # the 'sitemapdir' key is present in this configuration file.
40             #
41             # The sitemap page will auto update if you modify pages in
42             # 'pagedir' or in the 'autocheck' list below. If you modify
43             # static pages elsewhere in the web directory tree that are
44             # not listed in 'autocheck', you must DELETE the sitemap.xml
45             # file to force an update.
46             #
47             # [OPTIONAL]
48             #
49             # sitemapdir => '../ws_sitemap',
50              
51             # Directories to autocheck for sitemap update.
52             # you can list BOTH directories and individual files
53             # here relative to the web root. The 'sitemapdir' and
54             # 'pagedir' are always checked and do not need to be
55             # listed here.
56             #
57             # autocheck => ['docs'],
58              
59             # site map hint
60             #
61             # defaults to:
62             #
63             changefreq => 'monthly',
64              
65             # font family used throughout the document
66             #
67             face => 'VERANDA,ARIAL,HELVETICA,SAN-SERIF',
68              
69             # background color of the web page
70             # this can be a web color like 'white' or number '#ffffff'
71             #
72             backcolor => 'white',
73              
74             # Menu specifications
75             #
76             barcolor => 'red',
77             menudrop => '55', # drop down position
78             menuwidth => '100px', # width of menu item
79             pagewidth => '620px', # recommended
80             # menu font specifications
81             menucolor => 'black',
82             menuhot => 'yellow', # mouse over
83             menucold => 'white', # page selected
84             menustyle => 'normal', # bold, italic
85             menusize => '13px', # font points or pixels
86             sepcolor => 'black', # separator color
87              
88             # Page link font specifications
89             #
90             linkcolor => 'blue',
91             linkhot => 'green',
92             linkstyle => 'normal', # bold, italic
93             linksize => '13px', # font points or pixels
94              
95             # Page Text font specifications
96             #
97             fontcolor => 'black',
98             fontstyle => 'normal',
99             fontsize => '13px',
100              
101             # Heading font specifications
102             #
103             headcolor => 'black',
104             headstyle => 'bold', # normal, italic
105             headsize => '16px',
106             );
107              
108             # set default values where specs are missing
109             #
110             # return most recent mtime from pagedir or autocheck list if sitemap is enabled
111             #
112             sub checkspecs {
113 1     1 0 64 my $specs = shift;
114             # set defaults
115 1         6 for (my $i=0; $i < @defaults; $i+=2) {
116 26 50       121 $specs->{$defaults[$i]} = $defaults[$i+1]
117             unless exists $specs->{$defaults[$i]};
118             }
119 1         3 foreach('pagedir', 'javascript', 'sitemapdir') {
120 3 100       13 if (exists $specs->{$_}) {
121 2 50       7 $specs->{$_} = $' if $specs->{$_} =~ m|^/|;
122 2 50       12 $specs->{$_} .= '/' unless $specs->{$_} =~ m|/$|;
123             }
124             }
125 1 50       6 if (exists $specs->{sitemapdir}) {
126 0         0 my $mtime = (stat($specs->{pagedir}))[9];
127 0 0 0     0 if (exists $specs->{autocheck} && ref $specs->{autocheck}) {
128 0         0 foreach (@{$specs->{autocheck}}) {
  0         0  
129 0 0       0 $_ = $' if $_ =~ m|^/|;
130 0         0 my $t = (stat($_))[9];
131 0 0       0 $mtime = $t if $t > $mtime;
132             }
133             }
134 0         0 return $mtime;
135             }
136             }
137              
138             # generate the style library
139             #
140             # input: pointer to %specs
141             # number of columns
142             sub stylegen {
143 1     1 0 2 my($specs,$cols) = @_;
144 1 50       5 $cols = 1 unless $cols;
145             #
146             # .mhs menuHeadStyle
147             # .dropdown drop down style
148             # #mh menuHead
149             # A.B Basic link
150             # A.B:hover Basic link mouseOVER
151             # A.NU meNU link
152             # A.NU:hover meNU link mouseOVER
153             # A.CP menu link Current Page
154             #
155             # FONT.NU meNU font
156             # TD.NU meNU font
157             # TD.S Separator font
158             # .PT Page Text
159             # .HT Heading Text
160             #
161 1         10 my $styles = q|
250             |;
251             }
252              
253             # find the number of drop down menus
254             #
255             # input: pointer to pages hash
256             # page name
257             #
258             sub get_cols {
259 1     1 0 493 my($pp,$page) = @_;
260 1 50       5 return 0 unless exists $pp->{$page};
261 1         2 my $cols = 0;
262             # check for sub-menu's on menu items
263 1         3 foreach (@{$pp->{$page}->{menu}}) {
  1         5  
264             # count if there are sub menu's
265 4 100 66     30 ++$cols if exists $pp->{$_} && exists $pp->{$_}->{submenu} && @{$pp->{$_}->{submenu}};
  3   100     19  
266             }
267 1         4 return $cols;
268             }
269              
270             # generate values for 'name', 'href', 'onClick', 'link text', and 'status text'
271             #
272             # input: pointer to page hash,
273             # item
274             # returns: name, href, click, link text, status text
275             #
276             sub menuitem {
277 0     0 0 0 my($pp,$item) = @_;
278 0 0       0 return ($item, '#',
279             qq|onClick="return(npg('$item'));"|,
280             $item, $item
281             ) if exists $pp->{$item};
282 0         0 $item =~ m{(.)(.+)}; # skim off the first character
283 0         0 my $s = quotemeta $1; # the seperator character
284 0         0 my($name,$text,$status) = split(m{$s},$2);
285 0 0       0 $text = $name unless $text;
286 0 0       0 $status = $text unless $status;
287 0 0       0 return ($name, '#',
288             qq|onClick="return(npg('$name'));"|,
289             $text, $status
290             ) if exists $pp->{$name};
291 0         0 return ($name, $name,'',$text,$status);
292             }
293              
294             # generate menu bar
295             #
296             # input: pointer to page hash,
297             # page name
298             # page width
299             # debug page name
300             # return: html for menu,
301             # div html for dropdowns
302             #
303             # call this to fill a table row
304             # i.e. $pagehtml = '
'
305             # ($html,$div) = menugen(\%pages,$pagename);
306             # $pagehtml .= $html . $bodytext . $div;
307             # etc...
308             #
309             sub menugen {
310 0     0 0 0 my($pp,$page,$pw,$debug) = @_;
311 0         0 my @selectbar;
312 0         0 return (' ','') unless
313             exists $pp->{$page} && exists $pp->{$page}->{menu} &&
314 0 0 0     0 (@selectbar = @{$pp->{$page}->{menu}});
      0        
315 0         0 my $linkCount = 1;
316 0 0       0 my $menustripe = ( exists $pp->{$page}->{menustripe} )
317             ? qq|
$pp->{$page}->{menustripe}
318             | : '';
319 0         0 my $div = '';
320 0         0 my $html = q|
\n"; #;
321            
322 0 0       0 $html .= $#selectbar
323             ? ' align=center>'
324             : '>';
325 0         0 $html .= " 
326 0         0 my $bar = 0;
327 0         0 foreach(@selectbar) {
328 0         0 my($name,$href,$click,$text,$status) = menuitem($pp,$_);
329 0 0       0 if ($bar) {
330 0         0 $html .= q# | 
331             } else {
332 0         0 $bar = 1;
333             }
334 0 0       0 my $class = ($name eq $page)
335             ? 'CP' : 'NU';
336 0         0 $html .= qq|
337 0 0 0     0 if (exists $pp->{$name} &&
  0   0     0  
338             exists $pp->{$name}->{submenu} &&
339             @{$pp->{$name}->{submenu}}) { # build menu links
340 0         0 $html .= qq|id="L${linkCount}" href="$href" title="$status" onMouseout="return(headOut());" onMouseover="return(headOver('$status',$linkCount));" $click>$text
341             |;
342 0         0 $div .= qq|
343             |;
344 0         0 foreach my $sublink (@{$pp->{$name}->{submenu}}) {
  0         0  
345 0         0 ($name,$href,$click,$text,$status) = menuitem($pp,$sublink);
346 0 0       0 $click = qq|onClick="return(linkClick('$name'));"| if $click; # fix up click return
347 0 0 0     0 $class = ($name eq $page || $name eq $debug)
348             ? 'CP' : 'NU';
349 0         0 $div .= qq|$text
350             |;
351             }
352 0         0 $div .= q|
353             |;
354 0         0 ++$linkCount;
355             } else {
356 0         0 $html .= qq|href="$href" title="$status" onMouseover="return(oneOver('$status'));" onMouseout="return(linkOut());" $click>$text
357             |;
358             }
359             }
360 0         0 $html .= qq| 
361             $menustripe
362             |;
363 0         0 return($html,$div);
364             }
365              
366             # generate the trailer
367             #
368             # input: pointer to specs hash,
369             # pointer to page hash,
370             # page name,
371             #
372             # call this to fill a table row in the same manner as 'menugen'
373             # i.e. $pagehtml = '
'
374              
375             sub trailgen {
376 0     0 0 0 my($specs,$pp,$page) = @_;
377 0         0 my @selectbar;
378 0 0       0 return ' ' unless exists $pp->{$page}->{trailer};
379 0         0 my $html;
380 0         0 my $cols = 1;
381 0 0 0     0 if ( exists $pp->{$page}->{trailer}->{links} &&
  0         0  
382             ($cols = @selectbar = @{$pp->{$page}->{trailer}->{links}})) {
383             # $html = q|
384 0         0 $html = q|
#;
385             |;
386 0         0 $cols *= 2;
387 0 0 0     0 $cols += 1 if exists $pp->{$page}->{trailer}->{text} && $pp->{$page}->{trailer}->{text};
388 0 0       0 if ( exists $pp->{$page}->{trailer}->{top} ) {
389 0         0 $html .= qq|
$pp->{$page}->{trailer}->{top}
390             |
391             }
392 0         0 $html .= q|
 
393             |;
394 0         0 my $bar = 0;
395 0         0 foreach (@selectbar) {
396 0         0 my($name,$href,$click,$text,$status) = menuitem($pp,$_);
397 0 0       0 if ($bar) {
398 0         0 $html .= q# | 
399             } else {
400 0         0 $bar = 1;
401             }
402 0 0       0 my $class = $name eq $page ? 'CP' : 'NU';
403 0         0 $html .= qq|
404 0         0 $html .= qq|href="$href" title="$status" onMouseover="return(oneOver('$status'));" onMouseout="return(linkOut());" $click>$text
405             |;
406             }
407             }
408 0 0       0 my $ttop = ( exists $pp->{$page}->{trailer}->{top} )
409             ? qq|
$pp->{$page}->{trailer}->{top}
410             | : '';
411              
412 0 0 0     0 if (exists $pp->{$page}->{trailer}->{text} && $pp->{$page}->{trailer}->{text}) {
413 0 0       0 if ($html) {
414 0         0 $html .= q||;
415             } else {
416 0         0 $html = qq|
|; |;
417             $ttop
418            
|;
419             }
420 0         0 $html .= $pp->{$page}->{trailer}->{text} .q| 
421             }
422 0 0 0     0 if ( $html && exists $pp->{$page}->{trailer}->{bottom} ) {
423 0         0 $html .= qq|
424            
$pp->{$page}->{trailer}->{bottom}
425             }
426 0 0       0 return ' ' unless $html;
427 0         0 return $html .q|
428             |;
429             }
430              
431             # parse link text
432             #
433             # input: seperator,
434             # link string
435             # returns: page, text, status
436             #
437             sub parseLINK {
438 34     34 0 68 my($sep,$link) = @_;
439 34         42 $sep = quotemeta($sep);
440 34         189 my ($page,$text,$status) = split(m{$sep},$link);
441 34 100       80 $text = $page unless $text;
442 34 100       65 $status = $text unless $status;
443 34         94 return ($page,$text,$status);
444             }
445              
446             # replace LINK text
447             #
448             # input: pointer to page hash,
449             # html text
450             # returns: updated html
451             #
452             sub fixLINKs {
453 2     2 0 37 my($pp,$html) = @_;
454 2         24 while ($html =~ m{LINK([C-Z]?)\<(.)([^>]+)>}) {
455 34   50     141 my $class = $1 || "B";
456 34         65 my $match = quotemeta $&;
457 34         68 my($page,$link,$status) = parseLINK($2,$3);
458 34         81 my $replacement = q|
459 34 100       69 if (exists $pp->{$page}) {
460 16         30 $replacement .= q|onClick="return(npg('|. $page .q|'));" href="./">|;
461             } else {
462 18         29 $replacement .= q|href="|. $page .q|">|;
463             }
464 34         47 $replacement .= $link .q||;
465 34         764 $html =~ s/$match/$replacement/;
466             }
467 2         15 return $html;
468             }
469              
470             # generate text from file
471             #
472             # input: pointer to page hash,
473             # file name
474             # returns: html text
475             #
476             sub file2text {
477 5     5 0 530 my($pp,$file) = @_;
478 5         6 my $html;
479 5         11 local *F;
480 5 100 66     80 if (-e $file && open F, $file) {
481 1         5 local $/ = undef;
482 1         42 $html = fixLINKs($pp,);
483 1         14 close F;
484             } else {
485 4         6 $html = ' ';
486             }
487 5         15 return $html;
488             }
489              
490             # similar to above
491              
492             sub fileLoad {
493 0     0 0 0 my($file) = @_;
494 0         0 my $html;
495 0         0 local *F;
496 0 0 0     0 if (-e $file && open F, $file) {
497 0         0 local $/ = undef;
498 0         0 $html = ;
499 0         0 close F;
500             } else {
501 0         0 $html = '';
502             }
503 0         0 return $html;
504             }
505              
506             # return column array
507             #
508             # input: pointer to page hash,
509             # page name
510             # page width
511             # returns: column array
512             #
513             sub getColArray {
514 2     2 0 3 my($pp,$page,$pw) = @_;
515 1         4 return (exists $pp->{$page}->{column} && # column array
516             ref $pp->{$page}->{column} eq 'ARRAY')
517 2 100 66     16 ? @{$pp->{$page}->{column}}
518             : ($pw);
519             }
520              
521             # generate main body text
522             #
523             # input: pointer to specs hash,
524             # pointer to page hash,
525             # page name
526             # page width
527             # pages directory path
528             # returns: html
529             #
530             # call this to fill a table row in the same manner as 'menugen'
531             # i.e. $pagehtml = '
'
532             #
533              
534             sub bodygen {
535 2     2 0 490 my($specs,$pp,$page,$pw,$pd) = @_;
536 2 50       7 return '' unless exists $pp->{$page};
537 2         7 my @ca = getColArray($pp,$page,$pw);
538 2         4 my($smp,$smn); # sitemap path and position number
539 2 50 33     5 if ($page eq 'Sitemap' && exists $specs->{sitemapdir}) {
540 0         0 $smp = $specs->{sitemapdir} . 'sitemap.htxt';
541 0   0     0 $smn = $pp->{Sitemap}->{autocol} || 1;
542             }
543 2   50     11 my $phead = $pp->{$page}->{heading} || '';
544 2         5 my $html = q||."\n "; |; \n"; |; ';
545 2         4 foreach (@ca) {
546 4         10 $html .= q| 
547             }
548 2         3 $html .= "
549              
550 2         4 $_ = @ca; # number of columns
551 2 50       4 if ($phead) {
552 0         0 $html .= q|
|. $phead .q|
553             |;
554             }
555 2         6 $html .= q|
 
556            
557              
558 2         5 foreach (1..@ca) {
559 4         5 $html .= q||;
560 4 50 33     13 if ($smn && $smn == $_) {
561 0         0 $html .= file2text($pp,$smp);
562             } else {
563 4         8 my $file = $pd . $page .'.c'. $_;
564 4         9 $html .= file2text($pp,$file);
565             }
566 4         7 $html .= '
567             }
568 2         10 return $html .q|
|;
569             }
570              
571             # display the source for a page
572             #
573             # input: pointer to page hash,
574             # page name
575             # page width
576             # pages directory path
577             # returns html
578             #
579             # call this to fill a table row in the same manner as 'menugen'
580             # i.e. $pagehtml = '
'
581             #
582             sub srcgen {
583 0     0 0 0 my($pp,$page,$pw,$pd) = @_;
584 0 0       0 return '' unless exists $pp->{$page};
585 0         0 my $html = q|
586            
|. $page .q|
587            
588             
|;
589 0 0       0 my $tmp = (exists $pp->{$page}->{location})
590             ? $pp->{$page}->{location}
591             : $pd . $page;
592 0         0 $tmp = fileLoad($tmp);
593 0         0 $tmp =~ s|<|<|g;
594 0         0 $tmp =~ s|>|>|g;
595 0 0       0 chop $tmp if $tmp =~ /\n$/;
596 0         0 return $html . $tmp .q|
597            
598            
599            
|;
600             }
601              
602             # convert query string to hash
603             #
604 0     0   0 sub _cto { die "child query read timeout" }
605              
606             sub query2hash () {
607 9 50   9 0 1393 return () unless defined $ENV{REQUEST_METHOD};
608 9         38 my $tmp = uc $ENV{REQUEST_METHOD};
609 9         17 my $buff = '';
610 9 100 66     116 if ('GET' eq $tmp && defined $ENV{QUERY_STRING}) {
    100 66        
      100        
611 4         6 $buff = $ENV{QUERY_STRING};
612             }
613             elsif ('POST' eq $tmp && defined $ENV{CONTENT_LENGTH} && $ENV{CONTENT_LENGTH}) {
614 1         17 eval {
615 1         65 local $SIG{ALRM} = \&_cto;
616 1         13 alarm 5;
617 1         50 $tmp = read(STDIN,$buff,$ENV{CONTENT_LENGTH});
618 1         13 alarm 0;
619             };
620 1 50       3 return () if $@;
621             }
622             else {
623 4         14 return ();
624             }
625 5         8 my %qhash = ();
626 5         36 my @content = split(/&/,$buff);
627 5         22 foreach (@content) {
628 12         24 $_ =~ s/\+/ /g; # convert +'s to spaces
629 12         31 my($key,$val) = split(/=/,$_,2);
630             # convert hex characters back to ascii
631 12         12 $key =~ s/%(..)/pack("c",hex($1))/ge;
  0         0  
632 12         49 $val =~ s/%(..)/pack("c",hex($1))/ge;
  3         32  
633 12 50       23 if (exists $qhash{$key}) {
634 0         0 $qhash{$key} .= "\0" . $val;
635             } else {
636 12         41 $qhash{$key} = $val;
637             }
638             }
639 5         32 return %qhash;
640             }
641              
642             # build a web page
643             #
644             # input: pointer to specs,
645             # pointer to pages
646             # prints: to STDOUT
647             #
648             sub build {
649 0     0 1   my($specs,$pp) = @_;
650 0           my %query = &query2hash;
651 0   0       my $page = $query{page} || 'Home';
652 0 0         $page = 'Home' unless exists $pp->{$page};
653 0   0       my $tmp = $pp->{$page}->{debug} || '';
654 0           my $debug = '';
655 0 0         if ($tmp) {
656 0           $debug = $page;
657 0           $page = $tmp;
658             }
659 0           my $mtime = checkspecs($specs); # set defaults for missing specs
660              
661             # update the site map if needed
662 0           updsitemap($specs,$pp,$mtime);
663              
664             # build the head
665             #
666 0           my $pagedir = $specs->{pagedir};
667 0 0         my $title = (exists $pp->{$page}->{title})
    0          
668             ? $pp->{$page}->{title}
669             : (exists $pp->{$page}->{heading})
670             ? $pp->{$page}->{heading} : '';
671              
672 0           my $html = q|
673             | . $title .q|
674             |;
675 0           $tmp = fileLoad($pagedir . $page .'.meta');
676 0 0         $tmp = fileLoad($pagedir .'Default.meta')
677             unless $tmp;
678 0           $html .= $tmp;
679 0           $tmp = get_cols($pp,$page);
680 0           $html .= stylegen($specs,$tmp);
681 0           $html .= q|
683            
685            
687             |;
688 0           $tmp = fileLoad($pagedir . $page . '.head');
689 0 0         $tmp = fileLoad($pagedir .'Default.head')
690             unless $tmp;
691 0           $html .= $tmp;
692 0           $html .= q|
693            
694            
695            
696             You must enable Javascript1.2 or better
to view
697             all the features on this page
698            
699              
700            
701            
702            
703            
704            
|;
705              
706 0           $tmp = fileLoad($pagedir . $page .'.top');
707 0 0         $tmp = fileLoad($pagedir .'Default.top')
708             unless $tmp;
709 0           $html .= $tmp;
710 0           $html .= q|
711            
|;
712              
713 0           my $divtxt = '';
714 0 0 0       if ( exists $pp->{$page}->{menu} &&
  0   0        
715             ref $pp->{$page}->{menu} eq 'ARRAY' &&
716             @{$pp->{$page}->{menu}} ) {
717 0           (my $mnutxt,$divtxt) = menugen($pp,$page,$specs->{pagewidth},$debug);
718 0           $html .= $mnutxt . q|
719            
|;
720             }
721 0 0         if ($debug) {
722 0           $html .= srcgen($pp,$debug,$specs->{pagewidth},$pagedir);
723             } else {
724 0           $html .= bodygen($specs,$pp,$page,$specs->{pagewidth},$pagedir);
725             }
726 0           $html .= "\n". $divtxt .q| 
727            
728             |;
729 0 0 0       if ( exists $pp->{$page}->{trailer} &&
730             ref $pp->{$page}->{trailer} eq 'HASH' ) {
731 0           $html .= q|
|. trailgen($specs,$pp,$page) . q|
732             |;
733             }
734 0           $html .= q|
735             |;
736 0           print $html;
737             }
738              
739             ###################################
740             # sitemap code
741             ###################################
742              
743             # check for LINKs and HREFs in a scaffold page
744             #
745             # input: specs ptr,
746             # sitemap ptr,
747             # pages ptr,
748             # page name
749             # returns: last modified time for page
750             #
751             sub chk4links {
752 0     0 0   my($specs,$sm,$pages,$pg) = @_;
753             #print "CHK4LINKS $pg\n";
754             # load page text
755 0           local *H;
756 0           my $html = '';
757 0 0         opendir(H,$specs->{pagedir}) or die "could not open $specs->{pagedir}\n";
758 0           my @files = grep($_ =~ /${pg}\.[^~]+$/,readdir(H));
759 0           my $mtime = 0;
760            
761 0           foreach my $f (qw(meta head top)) { # include defaults
762 0 0         unless (grep(/$f$/,@files)) {
763 0           push @files, 'Default.'. $f;
764             }
765             }
766             {
767             #print "FILES = @files\n";
768 0           undef local $/;
  0            
769 0           foreach (@files) {
770 0           my $file = $specs->{pagedir} . $_;
771 0 0         next unless -e $file; # skip non-existent defaults
772 0           my $m = (stat($file))[9];
773 0 0         $mtime = $m if $mtime < $m;
774 0 0         next if $_ =~ /(?:meta|head)$/;
775 0 0         next unless open(H,$file);
776 0           $html .= ;
777 0           close H;
778             }
779             }
780             # check for LINKS
781 0           my @links;
782 0           while ($html =~ m{LINK\<(.)([^>]+)>}) {
783 0           $html = $` . $'; # reconstitute HTML with string removed
784 0           my $sep = $1;
785 0           my($plink,$text,$status) = parseLINK($1,$2);
786 0 0         next if exists $sm->{$plink};
787 0 0 0       if (exists $pages->{$plink}) {
    0          
788 0           $sm->{$plink} = [$sep,$plink,$status];
789 0           push @links, [$plink,1];
790             } elsif ($plink !~ m|\://| && $plink !~ /\@/) {
791 0           $sm->{$plink} = [$sep,$plink,$status];
792 0           push @links, [$plink,0];
793             }
794             }
795             # all links collected and marked, recurse links
796 0           foreach (@links) {
797 0           my($plink,$isLINK) = @{$_};
  0            
798 0           my $tab = $specs->{'_tab'};
799 0           push @{$specs->{'_sm'}}, [$tab,$plink];
  0            
800 0 0         if ($isLINK) {
801 0           rcursite($specs,$sm,$pages,$plink); # recurse if a menu page
802             } else {
803 0           chkLocalPage($specs,$sm,$plink);
804             }
805             }
806             # check for HREF's
807 0 0         return $mtime if nosearch($specs,$pg); # don't check links if no search
808 0           chk4hrefs($specs,$sm,\$html);
809 0           $mtime;
810             }
811              
812             # check for HREFs in an string
813             #
814             # input: specs ptr,
815             # sitemap ptr,
816             # string ptr,
817             #
818             sub chk4hrefs {
819 0     0 0   my($specs,$sm,$hp) =@_;
820             # while ($$hp =~ m{href=\"?([^?" \r\n]+)}) {
821 0           my @links;
822 0           while ($$hp =~ m{\r\n]+)(.*?<)/a>}si) {
823 0           my $match = $&;
824 0           my $link = $1;
825 0           $$hp = $` . $'; # reconstitute HTML with string removed
826 0           $2 =~ />(.*?)
827 0           my $text = $1;
828 0 0         next unless $text;
829 0 0 0       unless (exists $sm->{$link} || $link =~ m|\://|s || $link =~ /\@/s) {
      0        
830 0           my $sep; # scoping error in perl foreach 5.6.1
831 0           foreach ('#', '!', '%', '&',('0'..'9'),('A'..'Z'),('a'..'z')) {
832 0 0         next if $match =~ /$_/s;
833 0           $sep = $_;
834 0           last;
835             }
836 0           $sm->{$link} = [$sep,$link,$text];
837 0           push @links, $link;
838             }
839             }
840             # all links collected and marked, recurse them
841 0           my $tab = $specs->{'_tab'};
842 0           foreach my $link (@links) {
843 0           push @{$specs->{'_sm'}}, [$tab,$link];
  0            
844             #print "ck4............. $link to LCL\n";
845 0           chkLocalPage($specs,$sm,$link);
846             }
847             }
848              
849             # check for no search
850             #
851             # input: pointer to specs
852             # page name
853             # returns: true = no search
854             # else false
855             #
856             sub nosearch {
857 0     0 0   my($specs,$pg) = @_;
858 0 0         if (exists $specs->{nosearch}) {
859 0           foreach(@{$specs->{nosearch}}) {
  0            
860 0 0         return 1 if $pg =~ /$_/i;
861             }
862             }
863 0           return 0;
864             }
865              
866             # check an HTML page for HREF's
867             #
868             # input: specs ptr,
869             # sitemap ptr,
870             # string ptr
871             #
872             sub chkLocalPage {
873 0     0 0   my($specs,$sm,$pg) = @_;
874 0 0         $pg =~ s|/||
875             if $pg =~ m|^/|;
876 0 0         return unless -e $pg;
877 0           ${$sm->{$pg}}[3] = (stat($pg))[9];
  0            
878 0 0         return if nosearch($specs,$pg);
879             # ++$specs->{'_tab'};
880 0           local *F;
881             #print "LOCLPG $pg\n";
882 0 0         return unless open(F,$pg);
883 0           undef local $/;
884 0           my $html = ;
885 0           close F;
886 0           chk4hrefs($specs,$sm,\$html);
887             # --$specs->{'_tab'};
888             }
889              
890             # recurse through scaffold pages beginning with 'page' to build sitemap
891             #
892             # input: specs ptr,
893             # sitemap ptr,
894             # pages ptr,
895             # page name
896             #
897             sub rcursite {
898 0     0 0   my($specs,$sm,$pages,$pg) = @_;
899 0 0 0       return unless exists $pages->{$pg} && exists $pages->{$pg}->{menu}; # skip debug pages
900 0           my $tab = ++$specs->{'_tab'};
901             #print "RPAGE = ........ $pg\n";
902 0           my $count = 0;
903             # check menu's
904 0           my @pages = @{$pages->{$pg}->{menu}};
  0            
905 0 0         if (exists $pages->{$pg}->{submenu}) {
906 0           push @pages, @{$pages->{$pg}->{submenu}};
  0            
907             }
908 0 0 0       if (exists $pages->{$pg}->{trailer} && exists $pages->{$pg}->{trailer}->{links}) {
909 0           push @pages, @{$pages->{$pg}->{trailer}->{links}};
  0            
910             }
911 0           my @lclks; # local links this page
912 0           foreach (0..$#pages) {
913 0           my $pgname = $pages[$_];
914 0 0         next if exists $sm->{$pgname}; # pick off most of the page names early
915             #print "PROCESS $pgname\n";
916 0           my $text = my $status = $pgname;
917 0           my $sep = '#';
918 0 0         unless (exists $pages->{$pgname}) {
919 0           $pgname =~ m{(.)(.+)}; # skim off the first character
920 0           $sep = $1;
921 0           ($pgname,$text,$status) = parseLINK($1,$2);
922 0 0         $text = $pgname unless $text;
923 0 0         $status = $text unless $status;
924 0           $pages[$_] = $pgname;
925             }
926 0 0         next if exists $sm->{$pgname}; # pick off all processed page names
927 0 0 0       if (exists $pages->{$pgname}) { # if this is a scaffold page
    0          
928 0           $sm->{$pgname} = [$sep,$pgname,$status];
929 0           push @lclks, [$pgname,1];
930             }
931             elsif ($pgname !~ m|\://| && $pgname !~ /\@/) { # or a link but not absolute or mail
932 0           $sm->{$pgname} = [$sep,$pgname,$status];
933 0           push @lclks, [$pgname,0];
934             }
935             }
936             # chk4links($specs,$sm,$pages,$pg)
937             # unless exists $sm->{$pg};
938             # page level is established, recurse each link
939 0           foreach (@lclks) {
940 0           my($pgname,$isLINK) = @{$_};
  0            
941 0           push @{$specs->{'_sm'}}, [$tab,$pgname];
  0            
942             #print "RECURSING $pgname\n";
943 0 0         if ($isLINK) {
944 0           rcursite($specs,$sm,$pages,$pgname);
945             }
946             else {
947             #print "rcur........... $pgname to LCL\n";
948 0           chkLocalPage($specs,$sm,$pgname);
949             }
950             }
951 0           ${$sm->{$pg}}[3] = chk4links($specs,$sm,$pages,$pg);
  0            
952 0           --$specs->{'_tab'};
953             }
954              
955             # build a sitemap structure
956             #
957             # input: specs ptr,
958             # pages ptr
959             #
960             # returns: sitemap hash pointer
961             #
962             # REMEMBER to DELETE $specs->{_tab} {_sm} when done
963             #
964             sub sitestruct {
965 0     0 0   my($specs,$pages) = @_;
966 0           $specs->{'_tab'} = 0;
967 0           $specs->{_sm} = [];
968 0           my $sitemap = {
969             Home => ['#','Home','Home'],
970             Default => ['#','Default','Default'],
971             };
972 0           push @{$specs->{_sm}}, [0,'Home'];
  0            
973             # chk4links($specs,$sitemap,$pages,'Home');
974 0           chk4links($specs,$sitemap,$pages,'Default'); # include Default contents
975 0           delete $sitemap->{Default}; # page name does not belong in sitemap
976 0           rcursite($specs,$sitemap,$pages,'Home');
977 0           chkLocalPage($specs,$sitemap,'index.shtml');
978 0           return $sitemap;
979             }
980              
981             # return xml time for sitemap xml files
982             #
983             # input: time since the epoch
984             # returns: yyyy-mm-dd
985             #
986             sub xmltime {
987 0     0 0   my $time = shift;
988 0           my($mday,$mon,$year) = (localtime($time))[3,4,5];
989 0           ++$mon;
990 0           $year += 1900;
991 0           return sprintf("%04d-%02d-%02d",$year,$mon,$mday);
992             }
993              
994             # build html and xml sitemap pages
995             #
996             # input: specs ptr,
997             # pages ptr,
998             # sitemap ptr
999             #
1000             # returns: html string, xml string
1001             #
1002             sub sitemap {
1003 0     0 0   my($specs,$pp,$sm) = @_;
1004 0           my $html = '';
1005 0   0       my $port = $ENV{SERVER_PORT} || 80;
1006 0 0         $port = ($port == 80)
1007             ? '' : ':'. $port;
1008 0   0       my $srvr = $ENV{SERVER_NAME} || 'WebScaffoldText';
1009 0           my $xml = q|
1010            
1011             xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
1012             xsi:schemaLocation="http://www.sitemaps.org/schemas/sitemap/0.9
1013             http://www.sitemaps.org/schemas/sitemap/0.9/sitemap.xsd">
1014             |;
1015              
1016 0           my $now = xmltime(time);
1017 0           my $mtime = (stat($specs->{pagedir}))[9];
1018 0           $mtime = xmltime($mtime);
1019 0           my $cf = $specs->{changefreq};
1020              
1021 0           foreach (@{$specs->{'_sm'}}) {
  0            
1022 0           my($tab,$page) = @{$_};
  0            
1023 0           while (0 < $tab--) {
1024 0           $html .= '    ';
1025             }
1026 0           my($sep,$pg,$txt,$m) = @{$sm->{$page}};
  0            
1027 0 0         $m = 0 unless $m;
1028 0           my $ftime = xmltime($m);
1029             #print "SEP='$sep' PG='$pg' TXT='$txt'\n";
1030              
1031             # generate html
1032 0           $html .= 'LINK<'. $sep . $pg . $sep . $txt . $sep . $txt .">
\n";
1033             # generate xml
1034 0           $xml .= q|
1035             http://|. $srvr . $port;
1036 0 0         if (exists $pp->{$pg}) { # if this is a scaffold page
1037 0           $xml .= q|/index.shtml?page=|. $pg .q||;
1038             } else {
1039 0 0         if ($pg =~ m|^/|) {
1040 0           $pg = $';
1041             }
1042 0           $xml .= '/'. $pg . q||;
1043             }
1044 0           $xml .= q|
1045             |. $ftime .q|
1046             |. $cf .q|
1047            
1048             |;
1049             }
1050 0           $xml .= q|
1051             |;
1052 0           $html = fixLINKs($pp,$html);
1053 0           return ($html,$xml);
1054             }
1055              
1056             # check and update the sitemap
1057             #
1058             # input: specs ptr,
1059             # page ptr,
1060             # returns: sitemap structure pointer
1061             # else false
1062             #
1063             # writes htxt and xml pages if needed
1064             #
1065             sub updsitemap {
1066 0     0 0   my($specs,$pages,$pgt) = @_;
1067 0 0 0       return undef unless exists $specs->{sitemapdir} && # no update required, no sitemap
      0        
1068             -e $specs->{sitemapdir} &&
1069             -w $specs->{sitemapdir};
1070 0           my $smt = 0; # trial sitemap timestamp
1071 0           my $smf = $specs->{sitemapdir} .'sitemap.xml';
1072 0 0         if (-e $smf) {
1073 0           $smt = (stat($smf))[9];
1074             }
1075 0 0         return undef if $pgt <= $smt;
1076              
1077 0           local(*LOCK, *F);
1078 0           my $perms = 0644;
1079 0           my $oldmask = umask 022;
1080 0 0         unless (sysopen LOCK, $smf .'.lock', O_RDWR|O_CREAT|O_TRUNC, $perms) {
1081 0           umask $oldmask;
1082 0           $! = 11; # 11 Resource temporarily unavailable
1083 0           return undef;
1084             }
1085 0           umask $oldmask;
1086 0 0         unless (flock(LOCK, LOCK_EX())) {
1087 0           close LOCK;
1088 0           return 0;
1089             }
1090              
1091             # build the sitemap structure
1092 0           my $sm = sitestruct($specs,$pages);
1093              
1094             # build the html and xml text
1095 0           my($htext,$xtext) = sitemap($specs,$pages,$sm);
1096              
1097             # write the files
1098 0 0         if (open(F,'>'. $smf .'.tmp')) {
1099 0           print F $xtext;
1100 0           close F;
1101 0           rename $smf .'.tmp', $smf; # atomic update
1102             }
1103 0           $smf = $specs->{sitemapdir} .'sitemap.htxt';
1104 0 0         if (open(F,'>'. $smf .'.tmp')) {
1105 0           print F $htext;
1106 0           close F;
1107 0           rename $smf .'.tmp', $smf;
1108             }
1109 0           flock(LOCK,LOCK_UN());
1110 0           close LOCK;
1111             }
1112              
1113             # generate the structure of the site map, human readable
1114             #
1115             # input: specs ptr,
1116             # sitemap ptr
1117             #
1118             # returns: text
1119             #
1120             sub debugstruct {
1121 0     0 0   my($specs,$sm) = @_;
1122 0           my $txt = '';
1123 0           foreach (@{$specs->{'_sm'}}) {
  0            
1124 0           my($tab,$page) = @{$_};
  0            
1125 0           while (0 < $tab--) {
1126 0           $txt .= ' ';
1127             }
1128 0           $txt .= "@{$sm->{$page}}\n"
  0            
1129             }
1130 0           return $txt;
1131             }
1132              
1133             # generate the sitemap contents, not ordered, human readable
1134             #
1135             # input: sitemap ptr
1136             #
1137             # returns: text
1138             #
1139             sub debugsmap {
1140 0     0 0   my $sitemap = shift;
1141 0           my $txt = '';
1142 0           foreach (sort keys %$sitemap) {
1143 0           my @ary = @{$sitemap->{$_}};
  0            
1144 0           $txt .= "$_\t => @ary\n";
1145             }
1146             }
1147              
1148              
1149             ## generate sitemap hash
1150             #my $sm = sitestruct(\%specs,\%pages);
1151              
1152              
1153             #my ($htext,$xtext) = sitemap(\%specs,\%pages,$sm);
1154              
1155             #print $htext,"\n\n",$xtext;
1156             #print debugstruct(\%specs,$sm);
1157              
1158             # checkspecs(\%specs);
1159              
1160             #if (updsitemap(\%specs,\%pages)) {
1161             # print "DONE\n";
1162             #} else {
1163             # print "NOTHING\n";
1164             #}
1165             #delete $specs{_sm};
1166             #delete $specs{_tab};
1167              
1168             1;
1169             __END__