#!/usr/local/bin/perl

package Apache::ProgrammerHTML;

# --- ProgrammerHTML, The HTML for Programmers!
#     (c) 1997, 1998, 1999, 2000 by Rene K. Mueller <kiwi at the-labs dot com>
#
my $version = '$MyVersion: 0.067 - Thu Aug 28 13:56:30 CEST 2003 - kiwi$';
#
#       STATUS: BETA Release (handler() in ALPHA!!)
#
# DISTRIBUTION: Source code is only distributed by the author.
#               Do not distribute it by yourself as long the status is 
#               still ALPHA or BETA. The exclusive site obtaining the
#               source-code and updates is:
#
#                   http://the-labs.com/ProgrammerHTML/
#
#      LICENSE: THIS PROGRAM IS COPYRIGHTED BY RENE K. MUELLER (C) 1997-2000
#               AND YOU ARE FREE TO USE THIS PROGRAM FOR ANY PURPOSES AS
#               LONG THIS LICENSE & STATUS & DISTRIBUTION NOTES REMAIN
#               UNCHANGED.
#   
#
# $MyHistory$
#	28 Aug 2003: 0.067: NOT_FOUND error included .
#	24 Aug 2003: 0.066: plugin_calls init .
#	21 Jan 2003: 0.065: handler(): ">" occassionaly appeared, bug fixed .
#	03 Sep 2000: 0.064: bug fix for multiple %in{xyz} assignments, \0 separated now .
#	26 Jul 2000: 0.063: Makefile.PL for content-handler .
#	22 Jun 2000: 0.062: virtuals supported, with dedicated ./phtmlrc .
#	10 Jun 2000: 0.061: executable (-x) html define their own content-type .
#	31 May 2000: 0.059: PHTMLHeader support (text/html default, off, or dedicated) .
#	25 May 2000: 0.056: more clean up, handler() gets %in (cgi params) .
#	24 May 2000: 0.054: major source-code clean up & handler() .
#	19 May 2000: 0.052: modperl support, possible to use as cgi/mod_perl handler .
#	29 Jan 2000: 0.051: small fix about starting tag n .
#	28 Aug 1999: 0.049: webtree functionality built-in .
#	02 Mar 1999: 0.048: allow empty args within tags .
#	10 Oct 1998: 0.043: tags are case-insensitive (as it should be) .
#	22 Sep 1998: 0.041: perl called inline (faster) .
#	07 Aug 1998: 0.037: structure file supported .
#	26 Mar 1998: 0.020: norecursive improved 'def' can now include all kind of tags but '/def' always ends it.
#	03 Feb 1998: 0.017: phtmld (defined in the same code).
#	02 Jan 1998: 0.010: rename to phtml or ProgrammerHTML, excluded some plugin's and creating /usr/local/lib/phtml/, $ ( name ) variable use.
#	26 Dec 1997: 0.005: plug-in's implemented.
#	13 Dec 1997: 0.001: start, first version.

use strict;                   # --- forced to write clean code, ok ok . . . 
use FileHandle;
use POSIX qw(strftime);
# use Time::Hires qw(time);   # --- high-precision time (not just seconds)

($version) =~ s/^[^:]+: ([\d\.]+) .+$/$1/;
my $VERSION = $version;

my $me = "ProgrammerHTML $version"." ($$) [".strftime("%a %B %d %H:%M:%S %Y",localtime())."]";

$me = $0, $me =~ s/.+\/// unless($ENV{HTTP_HOST});

use Text::ParseWords qw(quotewords);
use Apache::Constants qw(:common);
use Apache::File ();

my $LIB = "/usr/local/lib/phtml/";
my @LIB_PATH = ($LIB,"$ENV{HOME}/.phtmlrc/","./");

my $verbose = 0;
my $browser_compatible = 1;   # --- first \n with <xyz></xyz> is dropped
my $args_assign = 'no';       # --- allow <sample a="abc" b c="test">
                              #     b will be "set"
# my %ENV;
my %myin;                     # --- so plugin can use it

$ENV{PHTML_LIB} = $LIB;

# --- we are it as daemon
if($me =~ /phtmld$/) {
   my $id = 0; # fork();
   my($mtime_dirlist,%mtime_dir);
   if($id==0) {
      print STDERR "$me: running, pid $$\n";
      while(1) {
         # --- never die
         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
            $atime,$mtime,$ctime,$blksize,$blocks) = 
            stat("$LIB/dirs");
         my @dirs;
         if($mtime>$mtime_dirlist) {
            open(F,"$LIB/dirs");
            while(<F>) {
               chop;
               s/\s+//g;
               push(@dirs,$_);
            }
            close(F);
            $mtime_dirlist = $mtime;
         }
         foreach my $d (@dirs) {
            my $update;
            opendir(D,"$d");
            my @files = grep(/.phtml$/,readdir(D));
            closedir(D);
            foreach my $f (@files) {
               ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                $atime,$mtime,$ctime,$blksize,$blocks)
                  = stat("$d/$f");
               if($mtime>$mtime_dir{$d}) {
                  # push(@files_todo,"$d/$f");
                  if($mtime>$mtime_dir{$d}) {
                     `cd $d; phtml -silent $f`;
                     # &conv("$d/$f");
                     $update = 1;
                  }
               }
            }
            $mtime_dir{$d} = time if($update);
         }
         sleep 3;
      }
      exit(0);
   }
   exit(0);
}

my($recursive,$silent,$outpath,@files,$curfile);

# --- parse the command arguments
while($#ARGV>=0) {
   $_ = shift(@ARGV);
   $recursive++, next if(/^-recursive/);
   $silent++, next if(/^-silent/);
   $verbose++, next if(/^-verbose/);
   $outpath = shift(@ARGV), next if(/^-outpath/);
   webtree(shift(@ARGV)), next if(/^-webtree/);
   push(@files,$_);
}

if(!$silent&&!$ENV{HTTP_HOST}) {
   print STDERR "$me: --- ProgrammerHTML V$version\n";
   print STDERR "$me: (c) 1997-2000 by Rene K. Mueller <kiwi\@the-labs.com>\n";
   print STDERR "$me:   see http://the-labs.com/ProgrammerHTML/\n";
}


# --- now we only have the files in @ARGV
@ARGV = @files;

# --- only one, but most powerful tag: def
my %syntax = (
   'def', 'builtin:container=yes',
   #'tree', 'builtin:container=yes',
);
# --- phtmlrc timestamp
my %rc_ts;

# --- checking phtmlrc files
unless($ENV{HTTP_HOST}) {
   my $p = @LIB_PATH[0];
   opendir(D,"$p");
   @files = grep(-x "$p/$_" && -f "$p/$_",readdir(D));
   closedir(D);
   foreach my $f (@files) {
      next if($f=~/phtmlrc/);
      my $fh = new FileHandle;
      if(open($fh,"$p/$f")) {
         print STDERR "$me: processing $p$f\n";
         process($fh,0);
         close($fh);
      }
   }
   
   # --- go for all defs
   foreach my $p (@LIB_PATH) {
      my $fh = new FileHandle;
      if(open($fh,"$p/phtmlrc")||open(F,"$p/.phtmlrc")) {
         print STDERR "$me: processing $p/phtmlrc\n";
         $curfile = "$p/phtmlrc";
         process($fh,0);
         close($fh);
      }
   }
} else {
   # --- in case we run as content handler,
   #     then we parse 'structure' file  (not)
   # webtree("$ENV{DOCUMENT_ROOT}/structure") 
   #    if(-f "$ENV{DOCUMENT_ROOT}/structure");
}

# --- global inline variables
my %var; 

# --- code of tags
my %render;

# --- javascript function declaration (reset for every file)
my %jsfunction;

# --- misc variables (and structure-file vars)
my(%plugin_calls,%parent,%child,%next,%prev,%title,%link,$outbuff);


# --- files to convert (preprocessor)
if($#ARGV>=0) {
   foreach my $f (@ARGV) {
      $curfile = $f; $ENV{'SOURCE_FILENAME'} = $f;
      $ENV{'REVERSE_PATH'} = reverse_path($ENV{'SOURCE_FILENAME'});
      conv($f);
   }

# --- as content-handler or cgi
} elsif($ENV{HTTP_HOST}) {
   # handler();

# --- neither, then let's walk through all dirs and
#     do the work . . . 
} else {
   open(F,".phtml-stat"); my $t = <F>; close(F);
   check_dir(".",$t);
   open(F,">.phtml-stat") || die "$me: cannot write time-stamp: $!\n";
   print F time(); close(F);
}

# --- the apache modperl-handler
# 
sub handler {
   my $r = shift;

   $r->content_type() eq 'text/html' || return DECLINED;

   %myin = ();
   # --- retrieve CGI arguments
   my @a = $r->method eq 'POST'?$r->content:$r->args;
   my($k,$v);
   while($k=shift(@a),$v=shift(@a),defined $k) {
      $myin{$k} .= "\0" if(defined $myin{$k});
      $myin{$k} .= $v;
   }
   
   if($verbose) {
      print "Content-type: text/html\n\n";
      foreach my $e (sort keys %ENV) {
         print "\$ENV{$e} = \"$ENV{$e}\"<br>\n";
      }
      print "<hr>\n";
   }
   chdir($ENV{DOCUMENT_ROOT});

   my $path = $ENV{DOCUMENT_ROOT};
   # $path =~ s/\/phtml$//;
   # $path =~ s/\/phtml.cgi$//;

   my $fh = new FileHandle;
   my $stdout = new FileHandle;
   $stdout = \*STDOUT;

   # my $file = $ENV{REQUEST_URI};
   my $file = $r->filename; 
   $file =~ s/[\00-\017]//g;
   $file = substr($file,0,1024);
   
   # --- PerlSetVar PHTMLHeader used?
   my $hs = $r->dir_config('PHTMLHeader');
   if(lc $hs eq 'off'||-x $file) {
      ;
   } elsif($hs) {
      print "Content-type: $hs\n\n";
   } else {
      print "Content-type: text/html\n\n";
   }
   
   # --- process phtmlrc (without output)
   my $ts = (stat("$path/phtmlrc"))[9];
   # if($ts>$rc_ts{$ENV{DOCUMENT_ROOT}}||!$syntax{"$ENV{DOCUMENT_ROOT}:def"}) {
   if($ts>$rc_ts{$ENV{DOCUMENT_ROOT}}) {
      print STDERR "$me: processing $path/phtmlrc (",$rc_ts{$ENV{DOCUMENT_ROOT}}?'update':'first time',")\n";
      # --- we reset all %syntax & %render of the related virtual (document_root)
      foreach my $e (keys %syntax) {
         my($p,$t) = split(/:/,$e);
         undef $render{$e}, undef $syntax{$e} if($p eq $ENV{DOCUMENT_ROOT});
      }
      $syntax{"$ENV{DOCUMENT_ROOT}:def"} = 'builtin:container=yes';
      if(open($fh,"$path/phtmlrc")) {
         $ENV{'SOURCE_FILENAME'} = $curfile = "$path/phtmlrc";
         process($fh,0) || return SERVER_ERROR;
         close($fh);
      }
      if($rc_ts{$ENV{DOCUMENT_ROOT}}&&!$syntax{"$ENV{DOCUMENT_ROOT}:def"}) {
         print STDERR "$me: STRANGE2: syntax is gone, but time-stamp exists ($ENV{DOCUMENT_ROOT})\n";
      }   
      $rc_ts{$ENV{DOCUMENT_ROOT}} = $ts;
   }
   if(-d $file) {
      my $found;
      foreach ('index.html','index.htm','') {
         $curfile = "$file/$_", $found = 1, last if(open($fh,"$file/$_"));
      }
      return SERVER_ERROR unless($found);
   } else {
      open($fh,$file) || return SERVER_ERROR;
   } 
   $ENV{'SOURCE_FILENAME'} = $curfile = $file;
   process($fh,$stdout) || return SERVER_ERROR;
   close($fh);
   return OK;
}

# --- the preprocessor, .phtml -> .html converter
sub conv {
   my($f) = @_;
   my($fnew,$k);
   
   # --- reset plugin-counter
   foreach my $k (keys %plugin_calls) {
      $plugin_calls{$k} = 0;
   }

   unless($f=~/\.phtml$/) {
      print STDERR "$me: $f is not Programmer-HTML, skipped\n";
      return;
   }
   ($fnew = $f) =~ s/\.phtml/.html/;
   $fnew =~ s/PHTML\//HTML\/$outpath/ if($outpath);
   my $fh = new FileHandle; my $fh2 = new FileHandle;
   my $st = time;
   open($fh,"$f") || die "$me: cannot read $f: $!\n";
   open($fh2,">$fnew") || die "$me: cannot write $fnew: $!\n";
   process($fh,$fh2);
   close($fh2);
   close($fh);

   print STDERR "$me: $fnew written (",time-$st," secs)\n";
}


# --- the nifty core of ProgrammerHTML
#     (still some perl4 style stuff there, requires some
#     clean-up, especially when 'use strict' would be used)
sub process {
   my($file,$dest) = @_;
   my @buff;
   my $norecursive;
   my @args;
   my @tag;
   
   %jsfunction = ();
   
   while($_=next_token('c',$file),length($_)) {
      if($_ eq '<') {
         my $name = next_token('v',$file);
         
         # --- end tag?
         if($name =~ s/^\/(.+)//) {
            $name = $1;
            my($n); ($n = $name) =~ tr/A-Z/a-z/;
            if(!syntax($n)||($norecursive&&$name ne @tag[$#tag])) {
               print $dest "$_/$name" if($#tag<0&&$dest);
               @buff[$#tag] .= "$_/$name" if($#tag>=0);
               next;
            }
            $name = $n;
            my $ltag = $#tag;
            my $tag_back = pop(@tag);
            if($tag_back ne $name) {
               print STDERR "$me: $curfile: bad </$name>, expected </$tag_back>\n";
               return 0;
            }
            while(1) {
               my $token = next_token('w',$file);
               last if($token eq '>');
            }
            print STDERR "$me: $curfile: calling &$name()\n" if($verbose);
            @buff[$ltag] =~ s/^ *\n// if($browser_compatible);
            my(@largs) = @{$args[$ltag]};
            if(syntax($name) =~ /^plugin/) {
               $_ = plugin($name,@buff[$ltag],@largs);
            } else {
               $_ = eval("&$name(\@buff[$ltag],\@largs);");
            }
            @buff[$ltag] = '';
            print $dest $_ if($#tag<0&&$dest);
            # --- tricky here, the previous buffer is added to the
            #     nested previous tag (nested tags)
            @buff[$#tag] .= $_ if($#tag>=0);
            $norecursive = 0 if($norecursive);
            
         } else {
            # --- it's definitly a start tag
            my($n,@largs);
         
            # --- well, hard to explain: if we already scan through
            #     a def-tag with inline-option, we do not accept nested 
            #     definitions (such as appearing as 
            #           print "<img src=\"test.gif\">
            #     therefore we do not recursivly scan/replace inline
            #     defs to avoid that screw up.
            $n = $name; $n =~ tr/A-Z/a-z/;
            if(!syntax($n)||$norecursive) {
               print $dest "$_$name" if($#tag<0&&$dest);
               @buff[$#tag] .= "$_$name" if($#tag>=0);
               next;
            }
            $name = $n; $a = 'do';
            while(length($a)) {
               $a = next_token('w',$file);
            check:
               last if($a eq '>');
               $b = next_token('w',$file);
               if($b ne '=') {
                  print STDERR "$me: $curfile: syntax error; '=' expected near $a $b ($a is 'set')\n"
                     if($args_assign eq 'yes');
                  push(@largs,$a);
                  push(@largs,'set');
                  $a = $b;
                  goto check;
               } else {
                  push(@largs,$a);
                  $b = next_token('w',$file);
                  push(@largs,$b);
               }
            } 
            if(syntax($name) =~ 'container=no') {
               print STDERR "$me: $curfile: calling &$name()\n" if($verbose);
               if(syntax($name) =~ /^plugin/) {
                  $_ = plugin($name,'',@largs);
               } else {
                  $_ = eval("&$name(\@largs);");
               }
               print $dest $_ if($#tag<0&&$dest);
               @buff[$#tag] .= $_ if($#tag>=0);
            } else {
               # --- hassle, when def is inline, we do not
               #     parse recursivly, special case.
               if($name eq 'def') {
                  foreach my $a (@largs) {
                     $norecursive = 1 if($a eq 'inline');
                  }
               }
               push(@tag,$name);
               @buff[$#tag] = '';
               @args[$#tag] = [@largs];
            }
         }
      } elsif($_ eq '$') { 
         my $o = next_token('c',$file);
         if($o eq '(') {
            my $name = next_token('w',$file);
            $o = next_token('c',$file);
      
            # --- when it runs as Apache::ProgrammerHTML under
            #     several VirtualHosts, then we need to distinct definitions
            $name = "$ENV{DOCUMENT_ROOT}:$name" if($ENV{DOCUMENT_ROOT});
   
            print STDERR "$me: $curfile: \$($name) missing ')'\n" if($o ne ')');
            if(defined($var{$name})) {
               print STDERR "$me: $curfile: insert \$($name)='$var{$name}'\n" if($verbose);
               @buff[$#tag] .= $var{$name} if($#tag>=0);
               print $dest $var{$name} if($#tag<0&&$dest);
            } else {
               print STDERR "$me: $curfile: var \$($name) used, but not defined\n";
            }
         } else {
            @buff[$#tag] .= "$_$o" if($#tag>=0);
            print $dest "$_$o" if($#tag<0&&$dest);
         }
      } else {
         @buff[$#tag] .= $_ if($#tag>=0);
         print $dest $_ if($#tag<0&&$dest);
      }
   }
   # --- we are done with the job, any stuff left on
   #     the tag-stack? 
   if($#tag>=0) {
      print STDERR "$me: $curfile: Error: you missed to close:\n";
      foreach my $i (0..$#tag) {
         print STDERR "$me:\t</@tag[$i]>\n"
      }
      print STDERR "$me: $curfile: Suggestion: correct the source-code!\n";
      return 0;
   }
   return 1;
}

sub syntax {
   my $n = shift;
   $n = "$ENV{DOCUMENT_ROOT}:$n" if($ENV{DOCUMENT_ROOT});
   return $syntax{$n};
}

my $cnum = 0;

# --- executing a plugin
#     some of the code is rather slow (e.g. redirecting
#     stdin/stdout) for the different languages
sub plugin {
   my($name,$buff,@args) = @_;
   my(%arg); my(%in);

   %arg = @args;
   %in = %myin;
   
   $ENV{'PLUGIN_NAME'} = $name;
   $ENV{'PLUGIN_CALLS'} = ++$plugin_calls{$name};
   
   my $name_orig = $name;
   # --- when it runs as Apache::ProgrammerHTML under
   #     several VirtualHosts, then we need to distinct definitions
   $name = "$ENV{DOCUMENT_ROOT}:$name" if($ENV{DOCUMENT_ROOT});
   
   if($syntax{$name} =~ /source=([^:]+)/) {
      # --- this is looks like this <xxx>$buff</xxx>
      my($source) = $1;

      if($source eq 'inline') {
         my($lang);
         if($syntax{$name} =~ /language=([^:]+)/) {
            $lang = $1;
         } elsif($ENV{HTTP_HOST}) {
            $lang = 'modperl';
         } else {
            $lang = 'perl';
         }

         # --- inline is c-source, a bit more tricky
         if($lang eq 'c') {
            my $script = 'c';
            
            open(X,">/tmp/phtml-$script-$$");
            print X $buff;
            close(X);
            
            open(X,">/tmp/phtml-$script-$$.c");
            print X $render{$name};
            close(X);
            `mkdir phtml-inline` if(!(-d "phtml-inline"));

            # --- get present signature of source
            my($sum,$len) = source_info($buff);
            open(F,"phtml-inline/$cnum-stat");
            $_ = <F>; my($sum2,$len2) = split(/\s+/); close(F);

            # --- has something changed?
            if($sum ne $sum || $len ne $len2) {
               `cc -o phtml-inline/$cnum /tmp/phtml-$script-$$.c -lm`;
            }
            unlink("/tmp/phtml-$script-$$.c");

            # --- write signature
            open(F,">phtml-inline/$cnum-stat");
            print F "$sum $len\n";
            close(F);
            # --- we need to prepare args for shell ''
            foreach my $i (0..$#args) { 
               $args[$i] = "'$args[$i]'";
            }
            $_ = `phtml-inline/$cnum @args < /tmp/phtml-$script-$$"`;
            unlink("/tmp/phtml-$script-$$");
            $cnum++;
            
         # --- inline is javascript, use its features
         } elsif($lang eq 'javascript') {
            my(@a);
            $_ = "<script language=javascript>\n";
            if(!$jsfunction{$name}) {
               $_ .= "function $name(";
               $_ .= "text";
               @a = @args;
               while($#a>=0) {
                  $_ .= ',';
                  $_ .= shift(@a); shift(@a);
               }
               $_ .= ") {\n";
               $_ .= $render{$name}."\n}\n";
               $jsfunction{$name} = 1;
            }
            $_ .= "$name(";
            $buff =~ s/[\n\r]/\\n/g;
            $_ .= "\"$buff\""; 
            @a = @args;
            while($#a>=0) {
               my($b);
               $_ .= ',';
               shift(@a); $b = shift(@a);
               $b =~ s/[\n\r]/\\n/g;
               $_ .= "\"$b\"";
            }
            $_ .= ");\n";
            $_ .= "</script>\n";
            
         # --- inline is perl, quite fast since no new perl is forked
         #     but stdin/stdout is cumbersome (maybe a better solution
         #     will be available
         } elsif($lang eq 'perl') {
            $source = $render{$name}; 
            my($cr) = sub { eval $source };
            unless($cr) {
               print STDERR "$me: $curfile: syntax error in $name\n";
            }

            # --- write body content of the tag ($buff) into a file
            open(X,">/tmp/phtml-$$.input"); print X $buff; close(X);

            my($out);
            # --- we open files for stdin/stdout 
            open(STDOUT,">/tmp/phtml-$$.output");
            open(STDIN,"/tmp/phtml-$$.input");

            # --- execute it
            &$cr;
            if($@) {
               print STDERR "$me: $curfile: syntax error in $name: $@\n";
            }
            unlink("/tmp/phtml-$$.input"); 
            close(STDOUT);
            
            # --- read output (stdout) for us
            $/ = "\n";
            open(X,"/tmp/phtml-$$.output");
            while(<X>) {
               $out .= $_;
            }
            close(X); 
            unlink("/tmp/phtml-$$.output");
            $_ = $out;


         # --- this is the modperl approach, input and output
         #     isn't done via stdin/stdout, fast enough for
         #     becoming content-handler for apache-http
         } elsif($lang eq 'modperl') {
            $outbuff = '';
            $arg{body} = $buff;
            my($cr) = sub { eval $render{$name}; };
            unless($cr) {
               print STDERR "$me: $curfile: syntax error in $name\n";
            }
            &$cr;
            if($@) {
               print STDERR "$me: $curfile: syntax error in $name: $@\n";
            }
            $_ = $outbuff;
         } else {
            print STDERR "$me: $curfile: '$lang' not supported as language (c, perl)\n";
         }

      # --- we have to start $source as executable (slow, but portable)
      } else { 
         my($f,$exec); my $script = 'foo';
         open(X,">/tmp/phtml-$script-$$");
         print X $buff;
         close(X);
         # --- we need to prepare args for shell ''
         foreach my $i (0..$#args) { 
            $args[$i] = "\"$args[$i]\"";
         }
         foreach my $f (@LIB_PATH) {
            if(-x "$f$source") {
               $_ = `$f$source @args < /tmp/phtml-$script-$$`;
               $exec = 1;
               last;
            }
         }
         print STDERR "$me: $curfile: Error: $source couldn't find plugin in (@LIB_PATH)\n" if(!$exec);
         unlink("/tmp/phtml-$script-$$");
      }
   } else {
      $_ = $render{$name};
      print STDERR "$me: $curfile: def-tag: before '$_' (replace \${$name} with '$buff')\n" if($verbose);
      s/\$\{$name_orig\}/$buff/g;
      foreach my $a (keys %arg) {
         print STDERR "$me: $curfile: def-tag: replace \${$a} with '$arg{$a}'\n" if($verbose);
         s/\$\{$a\}/$arg{$a}/g;
      }
   }
   $_;
}

sub out {
   foreach (@_) {
      $outbuff .= $_;
   }   
}

# sub print {
#    foreach (@_) {
#       $outbuff .= $_;
#    }   
# }

# ----------------------------------------------------------------------------
# --- here are all functions are declared, note you get all arguments
#     as area as argument

sub def {
   my($buff,@args) = @_;
   my(%arg);

   %arg = @args;

   my($name);
   
   if($arg{'variable'}) {
      my $name = $arg{'variable'};
      # --- when it runs as Apache::ProgrammerHTML under
      #     several VirtualHosts, then we need to distinct definitions
      $name = "$ENV{DOCUMENT_ROOT}:$name" if($ENV{DOCUMENT_ROOT});
      $var{$name} = $buff;
      return '';
   }
   $name = $arg{'name'};
   $name =~ tr/A-Z/a-z/;

   # --- when it runs as Apache::ProgrammerHTML under
   #     several VirtualHosts, then we need to distinct definitions
   $name = "$ENV{DOCUMENT_ROOT}:$name" if($ENV{DOCUMENT_ROOT});

   print STDERR "$me: $curfile: Error: $curfile: there is no name defined for <def>\n" 
      if(!$name);
   if($syntax{$name}) {
      print STDERR "$me: $curfile: Warning: '$name' already defined, overriding now\n";
   }
   $syntax{$name} = "plugin";
   if($arg{'plugin'}) {
      $syntax{$name} .= ":source=$arg{'plugin'}";
   }
   if($arg{'language'}) {
      $syntax{$name} .= ":language=$arg{'language'}";
   }
   $syntax{$name} .= ":container=$arg{container}" if($arg{container});
   $syntax{$name} .= ":run=$arg{run}" if($arg{run});
   $render{$name} = $buff;
   '';
}

my @charbuff;

sub myget {
   my($f) = @_;
   
   if($#charbuff>=0) {
      return shift(@charbuff);
   } else {
      my($buf);
      my($n) = read($f,$buf,256);
      if($n<=0) {
         return '';
      }
      @charbuff = split("|",$buf);
      return shift(@charbuff);
   }
}

sub next_token {
   my($mode,$f) = @_;
   my($s,$n,$str,$bsp,$c);

   $s = ''; $n = $str = 0;
   while($c=myget($f),length($c)) {
      print STDERR "$me: $curfile: <$c> character\n" if($mode eq 'c' && $verbose>1);
      $bsp = 0;
      # $c = myget($f), $bsp = 1 if($c=~/\\/);
      return $c if($mode eq 'c');
      unshift(@charbuff,$c), last if($mode eq 'v' && $c=~/[\s>]/);
      $s .= $c, next if($mode eq 'v');
      next if(length($s)==0&&!$str&&$c=~/\s/);
      $str = 1, next if(!$bsp&&!$str&&$c=~/"/&&$n==0);
      $s = $c, last if(length($s)==0&&!$str&&$c=~/[<>=]/);
      unshift(@charbuff,$c), last if(length($s)&&!$str&&$c=~/[\s<>=\(\)\[\]]/);
      last if(!$bsp&&$str&&$c=~/"/);
      $s .= $c;
      $n++;
   }
   print STDERR "$me: $curfile: <$s> token\n" if($verbose>1);
   $s;
}

sub source_info {
   my($txt) = @_;
   my($len,$sum);
   $len = length($txt);
   while(length($txt)>0) {
      $sum += ord(chop($txt));
   }
   ($sum,$txt);
}

sub reverse_path {
   my($p) = @_;
   my($r);
   # print STDERR "($p) -> ";
   $p =~ s/^\.\///;
   while($p=~s/^[^\/]+\///) {
      $r .= '../';
   }
   $r = '.' if(!$r);
   $r =~ s/\/$//;
   # print STDERR "($r)\n";
   $r;
}

# ------------------------------------------------------------------------- 
# built-in webtree (since we use this form very often)

sub webtree {
   my($strf) = @_;
   my(@parents,@lastf,$last,$mlast,$level,$maxlevel);
   my($p) = 'root';
   
   unless(open(F,$strf)) {
      print STDERR "$me: $strf was not found\n";
      return;
   }
   print STDERR "$me: webtree: $strf parsing\n";
   while(<F>) {
      chop;
      next if(/^\s*#/);
      foreach my $f (split(/\s+/,$_)) {
         # print STDERR "token: '$_'\n";
         if($f=~/html$/||$f=~/\/$/) {                      # .html file
            # $f = "./$f" unless($f=~/^\//);
            $f .= 'index.html' if($f=~/\/$/);
            $child{$p} .= ',' if($child{$p});
            $child{$p} .= $f;
            $next{$mlast} = $f if($mlast&&(!$next{$mlast}));
            $prev{$f} = $mlast if($mlast&&(!$prev{$f})); 
            $parent{$f} .= ',' if($parent{$f});
            $parent{$f} .= $p;
            $title{$f} = get_title($f);
            $last = $f;
            $mlast = $f;
         } elsif($f=~/\{/) {                                # children
            push(@parents,$p), $p = $last;
            push(@lastf,$last); $mlast = ''; $level++;
         } elsif($f=~/\}/) {                                # end children
            $level--, $p = pop(@parents), $mlast = pop(@lastf);
         }
         if($level<0) {
            print STDERR "$strf: error at >$last $_<, too many }'s\n";
            exit(1);
         }
         $maxlevel = $level if($maxlevel<$level);
      }
   }
   close(F);
   walk_tree('root');
}

sub walk_tree {
   my($p) = @_;
   foreach my $c (split(/,/,$child{$p})) {
      my($f) = $c;
      $f =~ s/\.html/.phtml/;
      push(@files,$f);
      walk_tree($c);
   }
}

sub get_title {
   my($f) = @_;
   my($title,$fp);

   local($/);

   $fp = $f;
   $f =~ s/\.phtml/.html/;
   $link{$fp} = $f;
   
   open(X,$f) || print STDERR "$me: webtree: couldn't find \"$f\"\n";
   $_ = <X>;
   if(/<title>([^<]+)<\/title>/i) {
      $title = $1;
   }
   close(X);
   $title;
}

sub check_dir {
   my($dir,$t) = @_;
   my(@files);
   print STDERR "$me: checking $dir ...\n";
   return if(-f "$dir/.no-phtml");
   opendir(D,"$dir");
   @files = grep(/\.phtml/||(!/^\./&&-d "$dir/$_"),readdir(D));
   closedir(D);
   foreach my $f (@files) {
      if(-d "$dir/$f") {
         check_dir("$dir/$f",$t) if($recursive);
      } else {
         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
            $atime,$mtime,$ctime,$blksize,$blocks) = stat("$dir/$f");
         if($mtime>$t) {
            $curfile = "$dir/$f"; $ENV{'SOURCE_FILENAME'} = "$dir/$f";
            $ENV{'REVERSE_PATH'} = reverse_path("$ENV{'SOURCE_FILENAME'}");
            conv("$dir/$f",$t);
         }
      }
   }
}

1;

# --- isn't it fun to study others hacks ;-)