# ----------------------------------------------------------
# Core CGI-style use routines for AHTML pages.
#

package Z;

use ZConfig;


# Z::write string
#
# Write output to the client.

sub write { $main::output .= $_[0]; }


sub set_settings {
   my( %defaults ) = @_;

   # base -> base for config keys
   # configfile -> specify config file location overriding server  

   # Get the user's settings and save them
   import_query_string();

   # make sure that there is only one back value
   if ( defined $::f{back} ) {
       ($::f{back}) = split /\s/, $::f{back};
   }
   my( %f ) = %::f;
   
   # install the defaults
   foreach( keys %defaults ) { $::f{$_} = $defaults{$_}; }

   # read our config settings
   import_config_settings( $defaults{configfile} );
   
   # override with our posted values
   foreach( keys %f ) { 
      # New key/value pairs are added from the form elements %<id>_<prefix>
      # and %<id>!<suffix>.  For example, if $::f{base} == modules, to add
      # modules!mime!types!pdf application/pdf, submit the form elements:
      # base=>modules, %1_mime!types=>pdf, %1=>application/pdf
      
      if( /^\%/ and $f{$_} ) {
         if( /^\%([^!]+?)_(.+)$/ ) {
            ($id, $prefix, $key) = ($1, $2, $f{$_});
            if( defined $f{"\%$id"} ) { $::f{"!$prefix!$key"} = $f{"\%$id"}; }
            
            # Handle child nodes:
            foreach( grep /^\%$id!/, keys %f ) {
               if( /^\%$id!(.*)$/ ) {
                  ($leaf) = ($1);
                  
                  $::f{"!$prefix!$key!$leaf"} = $f{"\%$id!$leaf"};
               }
            }
         }
      } else {
         $::f{$_} = $f{$_}; 
      }
   }
}

# Z::import_query_string
#
# Parse the query string and setup a hash for it
# if a hash of names and defaults are given only those are imported
# and their values are initially set to a default value
# Values are imported into %::f

sub import_query_string {
   $ENV{REQUEST_METHOD} = 'GET' unless defined $ENV{REQUEST_METHOD};
   
   if ( $ENV{REQUEST_METHOD} eq 'POST' ) {
      # Get query_string from STDIN
      # Ignore content length for now
      local $/=undef;
      $query_string = <STDIN>;
      
      if ( $ENV{QUERY_STRING} ) {
         # get this too 
         $query_string .= '&' . $ENV{QUERY_STRING};
      }
   } elsif ( $ENV{REQUEST_METHOD} =~ /^(GET|HEAD)$/ ) {
      $query_string = $ENV{QUERY_STRING};
   } else {
      $query_string = "";
   }
      
   # import into %::f
      
   my ( $key, $value );
   foreach $pair ( split /&/ms, $query_string ) {
      next if (!$pair);
      ( $key, $value ) = split /=/ms, $pair, 2;
      
      $key = &unquote_input($key);
      $value = &unquote_input($value);
      
      if( defined $::f{$key} ) {
         $::f{$key} = join $/||"\n", $::f{$key}, $value;
      } else {
         $::f{$key} = $value;
      }
   }
}


sub import_config_settings {
   my ( $configfile ) = @_; # optional
   my( $zc ) = new ZConf;

   if ( ! defined $configfile ) {
      if( defined $::f{server} ) {
         $configfile = "$ENV{ZEUSHOME}/webadmin/conf/sites/$::f{server}";
      } else {
         return;
      }
   } 
   
   # need to get server name from query_string
   $zc->ZConf::load( $configfile ) || ::Error (<<HERE);
Can\'t read config file $configfile
HERE
           
   $::f{configfile} = $configfile;
   $::f{base} = "" if( ! defined $::f{base} );
   
   foreach $key ( $zc->ZConf::listb( $::f{base} ) ) {
      my( $fqk ) = $::f{base}?"$::f{base}!$key":"$key";
      $::f{"!".$key} = $zc->ZConf::get( $fqk );
   }
}

# Z::f(name)
#
# Access to %::f assoc. array with html escaping

sub f {
   my ( $name ) = @_;
    
   if ( ! defined $::f{$name} ) {
      return "";
   } else {
      return &quote_html( $::f{$name} );
   }
}


# Z::hide( list )
#
# Returns html for hidden parameters
#
# Put together the html hidden inputs for the given field names

sub hide {
   my @hidden = @_;
   my $var;
   my $value;
   my $html = "";

   foreach $var ( @hidden ) {
      $value = $::f{$var};
      $value = "" if ! defined $value;
      
      $value = &quote_url( $value );
      
      $html .= "<input type=hidden name=\"$var\" value=\"$value\">\n";
   }
    
   return $html;
}


# Z::is_submit()
#
# Check whether this a first time thing or a submission

sub is_submit {
   return ( defined $::f{issubmit} and $::f{issubmit} eq $::f_name );
}


# Z::authenticate
#
# Print authentification headers and body

sub authenticate {
   print qq{WWW-Authenticate: basic realm=\"$_[0]\"
Status: 401 Authenticate

<html>
<head><title>Authentication required</title></head>
<body bgcolor=#ffffff>
<font size=+5>Authentication required:</font><br>
Security clearance needed for $_[0].
</body></html>
};
   exit 0;
}

# Z::encrypt
#
# Returns an encrypted password given a plaintext

sub encrypt
  {
     my ( $val ) = @_;

     my $md5 = "$ENV{ZEUSHOME}/admin/bin/md5";

     if ( ! &input_test( $val ) ) { return undef; }

     $val = `$md5 -pem -- \'$val\'`;
     chomp $val;
    
     if ( $? )
       {
          return undef;
       }
     else
       {
          return $val;
       }
  }

# Z::input_test
#
# Returns true if the external input is acceptable
# false if it is not
# For the purposes of cleaning input destined for backticks etc.

sub input_test {
    my ( $val ) = @_;
    
    if ( $val =~ /[^A-Za-z0-9_\.\-+=]/ ) {
       # Healthy paranoia - if other characters are required then they can be
       # added on the command line
       return undef;
    }
    else {
       return 1;
    }
}


    
# Z::redirect location
#
# Redirects a client to another page, does not return

sub redirect {
   my( $location, $query_string ) = @_;

   # redirect with anchors appears broken on some netscape browsers
   $location =~ s/\#[^\?]*//;
   
   if( $query_string) {
      if( $location =~ /\?/ ) {
         $location .= "\&$query_string";
      } else {
         $location .= "\?$query_string";
      }
   }
   
   if( $location =~ /\Q$ENV{REQUEST_URI}\E$/ ) {
      $location .= ($location =~ /\?/)?"\&cache=no":"?cache=no";
   }

   print qq{Location: $location
Content-Type: text/html
Pragma: no-cache

<html>
<head><title>Moved</title></head>
<body bgcolor=#ffffff>
That page has moved to <a href=\"$location\">$location</a>
</body></html>
};
    exit 0;
}


# Z::parse_url
#
# take a full or fragmented url and set up an array containing
# ( prefix, hostname, port, path ) making sensible guesses
#
# if a second arg is given it should be either 'file' or 'hostname'
# 
# To distinguish usefully between an unqualified file and a hostname
# in an abbreviated url - sensible guesses are taken of course

sub parse_url {
   my ( $url, $type ) = @_;
   my ( $prefix, $hostname, $port, $path, $query_string ) = 
         ( "", "", "", "", "" );
   my $file_mode = 1; # assume anything debatable is a file
   
   if ( defined $type && $type =~ /^h/ ) {
      $file_mode = 0;  # unless otherwise stated
   }
   
   # QUERY STRING
   
   # Get any query string off early as '?' is pretty distinctive
   # If it's not found it's not there
   
   if ( $url =~ s/\?(.*)$// ) {
      $query_string = $1;
   }
   
   # PREFIX
   
   if ( $url !~ s!^(\w{2,6}):\/\/!! ) {
      # Guess 
      if ( defined $ENV{HTTPS} && $ENV{HTTPS} =~ /on/i ) {
         # This is unlikely to be set without good reason
         # Use partial urls and let this find the connection type
         
         $prefix = 'https';
      } else {
         $prefix = 'http';
      }
   } else {
      $prefix = $1;
      $file_mode = 0; # Not a filename
   }
   
   # Hostname/filename final detection
   
   if ( $url !~ m!^/!    # If it doesn't start with a slash
      and (  
         # It has dots or colons before the first slash
         $url =~ m!([^\/]*)/! && $1 =~ m![\.:]! 
         or
         $url =~ m!^\w+(\.\w+){2,}!   # or starts word.word.word....
      ) ) {
      # Looks more like a hostname than a filename
      $file_mode = 0;
   }
   
   # HOSTNAME
   
   # From now, if we're still in file mode take guesses.
   # Everything else goes into the file path
   
   # Grab hostname (.....):8012 or (....)/foo.bar or guess
   
   my $hostmatch;
   
   if ( ! $file_mode ) {
      # if we're looking for hostnames
      if ( $hostmatch = $url =~ s!^([^:/]+)!! ) {
         $hostname = $1;
      }
   }
   
   if ( $file_mode or ! $hostmatch ) {
      # guess
      
      $hostname = $ENV{SERVER_NAME} if defined $ENV{SERVER_NAME};
      $hostname = $ENV{HTTP_HOST} if( defined $ENV{HTTP_HOST} );
      $hostname =~ s/:\d+//; # remove port number
   }
   
   # PORT
   
   # Grab port if there is one or guess
   
   my $port_match;
   
   if ( ! $file_mode ) {
      # if we're looking for a full url
      if ( $port_match = $url =~ s!^:(\d+)!! ) {
         $port = $1;
      }
   }
   
   if ( $file_mode or ! $port_match ) {
      # guess
      
      if ( defined $ENV{SERVER_PORT} ) {
         $port = $ENV{SERVER_PORT};
      } else {
         if ( $prefix eq 'https' ) {
            $port = 443;
         } else {
            $port = 80;
         }
      }
   }
   
   # PATH
   
   # Assume that the remaining is a file path
   
   if ( $url =~ m!^\/! ) {
      # absolute relative to docroot
      $path = $url;
   } else {
      if ( $url ) {
         # relative to PATH_INFO
         if ( defined $ENV{REQUEST_URI} ) {
            $path = $ENV{REQUEST_URI};
            $path =~ s!\/[^\/]*$!!; # remove any trailing filename and slash
         }
         $path .= '/'.$url;
      }   
   }
   
   return ( $prefix, $hostname, $port, $path, $query_string );
}


# Z::back
#
# Redirects the user back to the previous page, or "/" if there
# is no referer.

sub back {
   if ( defined $ENV{HTTP_REFERER} ) { redirect $ENV{HTTP_REFERER}; }
   else                              { redirect "/"; }
}


# Z::unquote_input
#
# Unescape URL-encoded data

sub unquote_input {
   my($todecode) = @_;
   $todecode =~ tr/+/ /;       # pluses become spaces
   $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
   return $todecode;
}


# Z::quote_url
#
# return string quoted appropriately to appear in a url

sub quote_url {
   my($toencode) = @_;
   $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
   return $toencode;
}


# Z::quote_html
#
# return string but with html-special characters escaped,
# necessary if you want to send unknown text to an html-formatted page.

sub quote_html {
   my($toencode) = @_;
   $toencode =~ s/&/\&amp;/g;
   $toencode =~ s/\"/&quot;/g;
   $toencode =~ s/</&lt;/g;
   $toencode =~ s/>/&gt;/g;
   return $toencode;
}


# Z::addheader
#
# Adds the given MIME-header and value to the output, assuming the rest of
# the processing goes normally.
# Expects 2 arguments, the mime-header, and the value

sub addheader {
   my( $key, $value ) = @_;
   $main::headers{$key} = $value;
}


# Z::include
#
# includes a given file at the current position (without parsing it)

sub include {
   my( $filename ) = @_;
   local $/;
   local *F;
   unless( open( F, "$filename" )) {
      Z::write( "<xmp>Unable to open file: $filename: $!</xmp>" );
      return;
   }
   my $data = scalar <F> || "";
   close F;
   Z::write( $data );
}


# Z::parse
#
# includes a given file at the current position, parsing it for Z
# comments (variables will be available to it, and any side effects it
# has will be visible after the parse).

@internal_parse_pwdstack = (); # private to parse!!

sub parse {
   my( $filename ) = @_;
   local *F;
   my ($pwd) = `pwd`; chomp $pwd;
   unless( open( F, "$filename" )) {
      Z::write( "<xmp>Unable to open file: $pwd/$filename: $!</xmp>" );
      return;
   }

   my $data;
   {
      local $/;
      $data = scalar <F> || "";
   }
   close F;

   # recursion is your friend

   # we push the current directory and chdir to the directory containing the
   # code we are parsing, so code being parsed has the invariant that
   # "pwd == directory containg currently parsed code".

   push @internal_parse_pwdstack, $pwd;

   # create directory owning file
   my $dirname = $filename;
   $dirname =~ s/[^\/]*$//;
   chdir( $dirname ) if ( $dirname ne "" );

   main::parse( $data );

   chdir( pop @internal_parse_pwdstack );
}


# Z::warn/error
#
# evaluates $_[0]; outputs $_[1] and inc error count if fails
# note: validate( undef, "foo" ) == validate( "foo" ), hence the unshift

sub warn {
   $_[1] || unshift @_, 0;
    
   return " " if( !is_submit() );
   return ""  if( $_[0] );

   $::f_warn++;
   return "<a name=\"errors\"><font color=#990000>$_[1]</font></a>";
}

sub error {
   $_[1] || unshift @_, 0;
    
   return " " if( !is_submit() );
   return ""  if( $_[0] );

   $::f_errs++;
   return "<a name=\"errors\"><font color=#990000>$_[1]</font></a>";
}

# Z::is_*
#
# Useful verification functions
# Can be used in Z::warn etc. 
sub is_int {
   return ($_[0] =~ /^[0-9]+$/);
}


# Z::form
#
# Starts form; creates unique $::f_name id used to track which form we
# submit/return to

sub form {
   my( %args ) = @_;
   $::f_name = $args{name}||++$::f_count;
   
   my %uri = ();

   ($uri{prefix}, $uri{hostname}, 
    $uri{port},   $uri{path}, 
    $uri{query_string} ) = parse_url( $ENV{REQUEST_URI} );   

   my $key;
   foreach $key ( keys %uri ) {
       if ( defined $::f{$key} ) {
	   $uri{$key} = $::f{$key};
       }
   }

   my( $location ) = "$uri{prefix}://$uri{hostname}";
   $location .= ":$uri{port}" if $uri{port};
   $location .= "$uri{path}";

   $target = $args{target}||$location;

   $location .= '?'."$uri{query_string}" if $uri{query_string};

   $back = $::f{back}||$ENV{REFERRER}||$target;
 
   # If base is set, us that, else use a empty string
   my( $base ) = defined( $::f{base} ) ? $::f{base} : "";

   return <<HERE;
<form name="$::f_name" action="$location" method=POST>
<a name=$::f_name>
<input type=hidden name=issubmit value="$::f_name">
<input type=hidden name=base value="$base">
<input type=hidden name=target value="$target">
<input type=hidden name=back value="$back">
</a>
HERE
}


# Z::msg
#
# To write messages into arbitrary places forwards and backwards in
# the returned HTML.  The endform used this to write warnings/error
# messages

sub msg_write {
   my( $tag, $str) = @_;
   
   $main::output =~ s/<!--msg: $tag-->/$str/;
}


# Z::endform
#
# Closes a form and immediately attempts to commit the changes

sub endform {
   if( is_submit() ) {      
      if( $::f_errs ) {
         msg_write( "error", <<HERE );
<b><font color=#990000>
Your changes have not been applied, because there were errors.<br>
<a href="#errors">Please correct them</a> and resubmit your configuration.
</font></b>
HERE
         return "</form>";
      }

      # commit configuration
      my( $zc ) = new ZConf;
      
      $zc->ZConf::load( $::f{configfile} );

      foreach $key (grep /^\!/, sort keys %::f) {
         ($keyf = $::f{base}.$key) =~ s/^\!//;
         $zc->ZConf::add($keyf, $::f{$key});
      }

# do deletions now.  Whatever happens, make sure that we're redirected
# so that the deletions are reflected in the display.  This means that
# warnings won't be shown

      my $deleted = 0;
      foreach $key( grep /^\-/, keys %::f ) {
         ($keyf = $::f{base}.$key) =~ s/\-//;
         $keyf =~ s/^!//;
         $zc->ZConf::delete( $keyf );
         $deleted = 1;
      }

      $zc->ZConf::save();

      if( !$deleted and $::f_warn ) {
         msg_write( "error", <<HERE );
<b><font color=#990000>
Your changes have been applied, although there were warnings reported.<br>
<a href="#errors">Please review these warnings</a>.
</font></b>
HERE
         return "</form>";
      }
      
      if ( $::f{target} ) {
         if ( ! defined $::f{server} ) {
            redirect( $::f{target} )
         } else {
            if ( $::f{target} =~ /server=/ ) {
               $::f{target} =~ s/server=[^&]*(&?)/server=$::f{server}$1/;
               redirect( $::f{target})
            } else {
               redirect( $::f{target}, "server=$::f{server}" );
            }
         }
      }
   }
   
   return "</form>";
}

# Z::form_table
#
# Takes args "base", "key" and "value", and enumerates all key/value pairs
# under $f::{base}!base for editing or deletion

sub form_table {
   my( %args ) = @_;
   my( $base ) = join "!", $::f{base}, $args{base};
   my( $html ) = "";
   
   $html = "<table border=2 cellspacing=2 cellpadding=2>\n";

   # Table heading line
   
   $html .= <<HERE;
<tr>
   <td bgcolor=#aaaaaa><b>$args{key}</b></td>
HERE
   # optional leaf data
   if( defined $args{leaf} ) {
      foreach ( @{$args{leaf}} ) {
         /(.*?) (.*) ([0-9]+)/;
         $html .= <<HERE;
   <td bgcolor=#aaaaaa><b>$2</b></td>
HERE
      }
   }
   if (defined $args{value}) {
      $html .= <<HERE;
   <td bgcolor=#aaaaaa><b>$args{value}</b></td>
HERE
   }
   $html .= <<HERE;
   <td>&nbsp;</td>
</tr>
HERE
   
   # Get the currently defined keys
   @keys = grep /^\!$args{base}!/, keys %::f;
   @keys = map { /^\!$args{base}\!([^!]+)/; $1 } @keys;
   %seen = (); @keys = sort grep { ! $seen{$_}++ } @keys;
   
   foreach $key ( @keys ) {
      ($checked) = (defined $::f{"-!$args{base}!$key"})?"checked":"";
      $html .= <<HERE;
<tr>
   <td bgcolor=#cccccc>$key</td>
HERE
      if( defined $args{leaf} ) {
         foreach ( @{$args{leaf}} ) {
            /(.*?) (.*) ([0-9]+)/;
            $keyname = "!$args{base}!$key!$1";
            $value = Z::f($keyname);
         $html .= <<HERE;
   <td bgcolor=#cccccc>
      <input type=text name="$keyname" value="$value" size=$3>
   </td>
HERE
         }
      } 
      if (defined $args{value}) {
         $keyname = "!$args{base}!$key";
         $value = Z::f($keyname);
         $html .= <<HERE;
   <td bgcolor=#cccccc>
      <input type=text name="$keyname" value="$value" size=30>
   </td>
HERE
      }
      $html .= <<HERE;
   <td>
      <input type=checkbox name="-!$args{base}!$key" value="1" $checked> Delete
   </td>
</tr>
HERE
   }

   $html .= <<HERE;
</table>
HERE
   return $html;
   
}

1;
