#!/usr/local/bin/perl


# LEGAL WARNING:
#
# This software is provided on an "AS IS", basis,
# without warranty of any kind, including without
# limitation the warranties of merchantability, fitness for
# a particular purpose and non-infringement. The entire
# risk as to the quality and performance of the Software is
# borne by you. Should the Software prove defective, you
# and not the author assume the entire cost of any service
# and repair.
#
=pod
What is the menu during the next week? Display it on the Web!
But you are a Webmaster and not lunch menu administrator (LUMA).
LUMA can not handle HTML pages, uploads, not even FrontPage.

What to do?

This is a general cgi script that can mix HTML templates, CGI input
and generates the HTML page that is instantly on the web.

For further information read the online documentation at

http://www.isys.hu/c/verhas/progs/perl/diweblo/index.html

=cut

$template_directory = 'd:/InetPub/wwwroot/progs/perl/diweblo/';
$Status = 'HTTP/1.0 200 OK';


$reference_text = 'This page was generated using diWEBlo v1.0';

$template_directory .= '/' unless $template_directory =~ m{/$};

{
my($p,$v); my @p; my $u = 
sub { $_[0] =~ tr/+/ /; $_[0] =~ s/%([0-9a-f]{2})/pack("c",hex($1))/ige; $_[0]; };
read STDIN, $p,$ENV{'CONTENT_LENGTH'}; @p = split('&',$p);
push @p, split('&',$ENV{'QUERY_STRING'});
for(@p) { ($p,$v) = split('='); $p = &$u($p); $v = &$u($v); $cgi->{$p} = $v; } 
}

if( $cgi->{'template'} ){
  $template_file = $template_directory . $cgi->{'template'} . '.template';
}else{
  $display = $cgi->{'display'};
  delete $cgi->{'display'};
  $template_file = $template_directory . $display . '.template';
}

open(F,"<$template_file") or &report_error("template file '$template_file' is not openable");
$old_sep = $/;
$/ = undef;
$template = <F>;
close F;
$/ = $old_sep;
$template = &string_to_hash( $template );

#
#          CHECK PASSWORD IF NEEDED
#
if( defined( $template->{'Password'} ) && ! defined($display) ){
  if( $cgi->{'Password'} ne $template->{'Password'} ){
    &report_error('Password is incorrect.');
  }
}

#
#          PASSWORD IS NEEDED, WE SHOULD DELETE IT BEFORE
#          IT GETS SOMEHOW INTO THE DATA FILE
#
delete $cgi->{'Password'};

#
#          GET THE OUTPUT FILE NAME
#
if( $template->{'File'} ){
  $file_name = $template->{'File'};
}else{
  $file_name = $cgi->{'File'};
}
$directory = $template->{'Directory'};
$directory .= '/' if defined($directory) && ! $directory =~ m{/$};
$html_file = $directory . $file_name;

#chop off extension i.e.:  index.html -> index
$file_name =~ s{\..*$}{};
# convert \ to / 
# i.e.: c:\inetpub\wwwroot\progs\perl\diweblo\index 
#         -> c:/inetpub/wwwroot/progs/perl/diweblo/index
$file_name =~ s{\\}{/}g;
# chop off path from front c:/inetpub/wwwroot/progs/perl/diweblo/index -> index
$file_name =~ s{^.*/}{};

#
# Get the data file name
#
if( defined( $template->{'Data'} ) ){
  $data_file = $template->{'Data'} . '/' . $file_name . '.data';
}else{
  $data_file = undef;
}

if( open(DATA,"<$data_file") ){
  $old_sep = $/;
  $/ = undef;
  $data = <DATA>;
  close DATA;
  $/ = $old_sep;
  $data = &string_to_hash($data);
  # get all values that are not defined in the CGI variables
  while( ($k,$v) = each %{$data} ){
    $cgi->{$k} = $v unless defined $cgi->{$k};
  }
}

if( $data_file && ! defined($display) ){
  open(DATA,">$data_file") or &report_error("Can not open data file. $data_file");
  print DATA &hash_to_string($cgi);
  close DATA;
}

if( defined($display) ){
  $template_text = $template->{'Edit'};
  if( ! defined( $template_text ) ){
    $template_file = $template->{'EditFile'};
    if( open(T,"<$template_file") ){
      $old_sep = $/;
      $/ = undef;
      $template_text = <T>;
      $/ = $old_sep;
      close T;
    }
  }
}

$template_text = $template->{'Template'}
               unless defined( $template_text );

if( ! defined( $template_text ) ){
  $template_file = $template->{'TemplateFile'};
  if( open(T,"<$template_file") ){
    $old_sep = $/;
    $/ = undef;
    $template_text = <T>;
    $/ = $old_sep;
    close T;
  }
}

$cgi->{'diweblo'} = $reference_text;

while( ($k,$v) = each %{$cgi} ){
  $template_text =~ s/<!--\s*#\s*diweblo\s+$k\s*-->/$v/g;
}

if( $display ){
  print <<END;
$Status
Content-type: text/html

$template_text
END
}else{
  open(F,">$html_file") or &report_error("Can not open the html file: $html_file");
  print F $template_text;
  close F;
  print <<END;
$Status
Content-type: text/html

<HTML>
<HEAD><TITLE>$message</TITLE>
</HEAD>
<BODY>
<FONT SIZE=6 FACE="ARIAL"><B>OK</B></FONT>
<HR>
<FONT SIZE=3 FACE="ARIAL">
Your request was successfully processed, diWEBlo has created
the requested page.
</FONT>
</BODY>
</HTML>
END
}

exit;
sub string_to_hash {
  my $buffer = shift;

  my %bin = ();
  my @lines = split(/\n/,$buffer);
  my @hierarchy = ();

  while( defined($_ = shift @lines) ){
    if( /^\s*$/ ){next}#skip empty lines
    if( /^\s*#/ ){next}#skip comment lines
    my $key = $_;
    $_ = $_ . "\n";
    my $value = '';
    if( /([^:]*):\s*(.*)/ ){ #key: value
      $key = $1;
      $value = $2;
    }

    if( $key =~ s/^(\-*)// ){ $level = length $1; }else{ $level = 0; }
    $#hierarchy = $level -1;
    push @hierarchy,$key;
    $key = join('.',@hierarchy);
    @hierarchy = split(/\./,$key);#in case the key contains dot, like -apple.golden for fruit.apple.golden
    if( $value eq ''){ next };
    if( $value =~ /^--/ ){
      my $EndString = "$value\n";
      $value = '';
      while( defined($_ = shift @lines) ){
        $_ = $_ . "\n";
        if( $_ eq $EndString ){ last; }
        if( /\\\n/ ){ chop; chop; }#if the eoln is quoted then chop it off
        $value .= $_;
      }
    }else{
      chomp $value;
    }
    $bin{$key} = $value;
  }
  return \%bin;
}

sub hash_to_string {
  my $bin = shift;

  my $buffer = '';

  my @keys = sort keys %{ $bin };

  my @hierarchy = ();
  for $key ( @keys ){
    my $hlen;
    $value = $bin->{$key};
    if( $#hierarchy > -1 ){
      my $l;
      my @klist = split(/\./,$key);
      $key = '';
      $hlen = -1;
      for( @hierarchy ){
        $l = shift @klist;
        if( $_ eq $l ){
          $key .= '-';
          $hlen ++;
          }else{
          unshift @klist,$l;
          last;
        }
      }
      $#hierarchy = $hlen;
      for( @klist ){ push @hierarchy,$_ }
      $key .= join('.',@klist);
    }else{
      @hierarchy = split(/\./,$key);
    }
    my @vlist = split(/\n/,$value);
    
    if( $#vlist > 0 || $value =~ /^--/ || $value =~ /\n$/ ){
      my $EndString = '--';
      my $i = 2;
      for( @vlist ){
        if( /^--/ ){#if the line starts with --
          my $c = substr($_,$i,1);
          $i++;
          if( $c eq 'a' ){ $EndString .= 'b'; } else { $EndString .= 'a'; }
        }
      }
      #if the last line does not end with new line character then append a \
      if( $value !~ /\n$/ ){ $value .= "\\\n"; }
      $buffer .= "$key: $EndString\n$value$EndString\n";
    }else{
      $buffer .= "$key: $value\n";
    }
  }
  return $buffer;
}


#
# EMIT ERROR TO THE CLIENT AND EXIT
#
sub report_error {
  my $message = shift;
  print <<END;
$Status
Content-type: text/html

<HTML>
<HEAD><TITLE>$message</TITLE>
</HEAD>
<BODY>
<FONT SIZE=6 FACE="ARIAL"><B>ERROR</B></FONT>
<HR>
<FONT SIZE=3 FACE="ARIAL">
An error occured while processing your request. The error message is:<P>
<CENTER>
<B>
$message
</B>
</CENTER>
</FONT>
</BODY>
</HTML>
END
  exit;
}