#!c:/perl/bin/perl

###############################################################
#
# aXML parser v3.4
#
# Author : Simon Odell 
# Email : simonodell@hotmail.com
# 
# Description : A standalone single file parser for rendering
# aXML into HTML documents. 
# 
################################################################

my $debugcmds = 0;
my $logcmds = 0;
my $log;
my $debugsys = 0;
my $aXML_mem;
my $qd;
my $temp_debug = 0;

if (($debugsys)||($debugcmds)||($temp_debug)) { print "Content-type: text/html\n\n"; }

################################################################
#
#  File handling routines 
#  routines for manipulating server side files
# 
################################################################
  
#get and return the contents of a given filename
#getFile ("filename.file");

sub getFile
  {
   my $fileName = shift(@_);
   
   if ($debugsys) { print "GetFile : $fileName\n"; }
   
   undef $/;
   open $file, $fileName;
   my $buf = <$file>;
   close $file;
   
   $buf =~ s@\[@<lftsqbrk/>@g;
   $buf =~ s@\]@<rtsqbrk/>@g;
   $buf =~ s@\(@<lftbrk/>@g;
   $buf =~ s@\)@<rtbrk/>@g;
   $buf =~ s@\+@<plus/>@g;
   $buf =~ s@\?@<ques/>@g;
      
   return $buf;
  }

sub getPlugin
  {
   my $fileName = shift(@_);
   
    if ($debugsys) { print "GetPlugin : $fileName\n"; }
   
   undef $/;
   open $file, $fileName;
   my $buf = <$file>;
   close $file;
   return $buf;
  }
    
# write given data to a specified file  
# writeFile("<filename>filename</filename><data>$data</data>");

sub writeFile
  {
   my $data = shift(@_);
   
   if ($debugsys) { print "WriteFile : $data\n"; }
      
   if ($data =~ m@<filename>(.*?)</filename>@s) { $filename = $1; }
   if ($data =~ m@<data>(.*)</data>@s) { $filedata = $1; }	  
   open(DAT,">$ENV{DOCUMENT_ROOT}/$filename") || return 0;
   print DAT $filedata; 
   close(DAT);
   return 1;
  }
  
# delete specified file  
# delFile("filename.file");  
  
sub delFile
  {
   my $data = shift(@_);
   
   if ($debugsys) { print "DelFile : $data\n"; }
     
   return unlink($data);
  }

################################################################
#
#  Load configuration file and create $config hash
# 
################################################################

$aXML_conf_file = getFile ("$ENV{DOCUMENT_ROOT}/aXML_conf.xml");

if ($debugsys) { print "axml conf file = \n\n$aXML_conf_file\n\n\n\n"; }

while ($aXML_conf_file =~ m@<(.*?)>(.*?)</(.*?)>@s)
     {
	  $tagname = $1;
	  $tagvalue = $2;
	  
	  if ($debugsys) { print "conf tag : $tagname = $tagvalue\n"; }
	  
	  $config->{$tagname} = $tagvalue;
	  	  
	  $aXML_conf_file =~ s@<$tagname>$tagvalue</$tagname>@@;
     }   

  
  

################################################################
#
#  Query data handling section
#  builds a hash table called qd which stores the query data 
#  values
# 
################################################################

if ($debugsys) { print "Parsing Query Data \n ----------------------\n\n"; }
 
   if ($ENV{'REQUEST_METHOD'} eq 'GET') 
	   {
        @query_string_pairs = split(/&/, $ENV{'QUERY_STRING'});
       }
     elsif ($ENV{'REQUEST_METHOD'} eq 'POST') 
       {
        read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
        @query_string_pairs = split(/&/, $buffer);
       }
     else { &error('request_method'); }
       
foreach $pair (@query_string_pairs)
  {
   ($key,$value) = split /=/, $pair;
   $value =~ tr/+/ /;
   $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
   $qd->{$key} = $value;
  }     

#if no get type specified assume axml
if ($qd->{gettype}){ } else { 
	
	if ($ENV{HTTP_USER_AGENT} =~ m@wirewolf@s)
	  {
	   $qd->{gettype} = "axml";
	  }
	else
	  {
	   $qd->{gettype} = "html";
      }
   } 

#if no action load default action
if ($qd->{action}){ } else { $qd->{action} = "default"; }

#if no lang given take default lang from axml config file
if ($qd->{lang}){ } else { $qd->{lang} = $config->{lang}; }  


if ($debugsys) {

	 while ( my ($key, $value) = each(%$qd) )
	   {
        print "qd->{$key} => $value\n";
       }

  print "\n\n\n"; 
 }
 
 
################################################################
#
#  Setup Logging file 
#  if logcmds flag set, load log file and append new entry
# 
################################################################
 
 
 
if ($logcmds)
  {
   $log = getFile("$ENV{DOCUMENT_ROOT}/logs/$qd->{action}.log");	  
   $log .= "\n\n\n\n\n\n Action Called @ insert date/time here\n
                         -------------------------------------\n\n";	  
  } 
 

################################################################
#
#  Session handling routines 
#  routines for keeping users signed in across multiple requests
# 
################################################################

@timeData = localtime(time);
$currenttime = join(',', @timeData);    
#clear out old sessions

if ($debugsys) { print "Clearing out old sessions \n ----------------------\n\n
                        Session Folder = $ENV{DOCUMENT_ROOT}/sessions\n\n"; }
   

my @sessions = glob("$ENV{DOCUMENT_ROOT}/sessions/*.xml");
foreach $session (@sessions) 
  {
   if ($debugsys) { print "Checking session : $session\n"; }	  
	  
   $session_data = getFile($session);
      
   if ($session_data =~ m@<timestamp>(.*?)</timestamp>@s)
     {
	  @timestamp = split /,/,$1;
	  
	  if (@timestamp[2] lt @timeData[2])
	    {
		 delFile($session);   
   	    }        
     }
  } 
    
if ($debugsys) { print "\n\n\nUpdate current session \n ----------------------\n\n"; }
      
   $currentIP = $ENV{REMOTE_ADDR};
   $currentIP =~ s@\.@@g;
   
   my $username;
   my $userlevel;
   my $loggedin = 0;
   
   if ($session_info = getFile("$ENV{DOCUMENT_ROOT}/sessions/$currentIP.xml"))
     {
	  if ($session_info =~ m@<username>(.*?)</username>@s) { $username = $1; }
      if ($session_info =~ m@<userlevel>(.*?)</userlevel>@s) { $userlevel = $1; }

	  #update the file with new timestamp
      
      writeFile("<filename>sessions/$currentIP.xml</filename>
                  <data><username>$username</username>
                       <userlevel>$userlevel</userlevel>
                       <timestamp>$currenttime</timestamp></data>");
      $loggedin = 1;
     }  
  
################################################################
#
#  Plugin handler 
#  builds a hash table called plugins which stores the plugin code
# 
################################################################

#get a dir list of the plugin directory
my @plugins = glob("$ENV{DOCUMENT_ROOT}/plugins/server/*.*");
my @commands;

if ($debugsys) { print "\n\n\nLoading Plugins\n------------------\n\n"; }
    

#load the server side plugins into a hash table called plugins, 
#and save the names of the plugins into an array called commands
    
foreach $plugin (@plugins) 
  {
   if ($plugin =~ m@.*/(.*?).aXMLpi@s)
     {
	  $command_name = $1;   
	  $plugins->{$command_name} = getPlugin ($plugin);
   	  push (@commands, $command_name);
	 }  
  }
  
#add gettype specific plugins
my @plugins = glob("$ENV{DOCUMENT_ROOT}/plugins/server/$qd->{gettype}/*.*");

foreach $plugin (@plugins) 
  {
   if ($plugin =~ m@.*/(.*?).aXMLpi@s)
     {
  	  $command_name = $1;   
	  $plugins->{$command_name} = getPlugin ($plugin);
      push (@commands, $1);
  	 }  
  }
  
#add action specific plugins
my @plugins = glob("$ENV{DOCUMENT_ROOT}/actions/$qd->{action}/plugins/*.*");
    
foreach $plugin (@plugins) 
  {
   if ($plugin =~ m@.*/(.*?).aXMLpi@s)
     {
	  $command_name = $1;   
	  $plugins->{$command_name} = getPlugin ($plugin);
	  push (@commands, $1);
     }  
  }
  
################################################################
#
#  Process Objects 
#  
#  objects are like macros, scanned for and processed prior to
#  the main parsing, they allow for neater code in the action
#  file. 
# 
################################################################


#load the specified action file
my $actionFile = getFile("$ENV{DOCUMENT_ROOT}/actions/$qd->{action}.aXML");

#load the objects
if ($debugsys) { print "\n\n Loading Objects\n---------------------\n\n"; }
 

my @objects = glob("$ENV{DOCUMENT_ROOT}/objects/*.*");
foreach $object (@objects) 
  {
   if ($object =~ m@.*/(.*?).aXMLobj@s)
     {
	  $object_name = $1;   
	  $objects->{$object_name} = getFile ("$ENV{DOCUMENT_ROOT}/objects/$object_name.aXMLobj");
	  push (@objects, $1);
     }  
  }

#parse action file for objects and insert  
if ($debugsys) { print "\n\n\nInserting Objects\n---------------------\n\n"; }
 
$rescan = 1;  

while ($rescan)
     {
	  $rescan = 0;

      foreach $object (@objects)
         {
          while ($actionFile =~ m@<$object(.*?)>(.*?)</$object>@s)
               {
	            $raw_object_args = $1;
	            $object_contents = $2;   

	            @raw_object_args = split / /,$raw_object_args;
	            foreach $raw_object_arg (@raw_object_args)
	              {
		           if ($raw_object_arg =~ m@(.*?)="(.*?)"@s)
		           {
			        $handed_object_args->{$1} = $2;
			       }
	            }    
	            
	            if ($debugsys) { print "Found Object ref : $object $raw_object_args\n"; }
 	  
          	    if ($objects->{$object} =~ m@<type>(.*?)</type>@s) { $type = $1; }
	            if ($objects->{$object} =~ m@<args>(.*?)</args>@s) { $args = $1; }
	            if ($objects->{$object} =~ m@<contents>(.*?)</contents>@s)
	              {
		           $contents = $1;
		           $contents =~ s@<contents/>@$object_contents@s;
		          }
		        else
		          {
			       $contents = $object_contents;
		          } 
	            
	            my $object_args; 
	            $find_more_args = 1;
	            while ($find_more_args)
	                 {
		              $find_more_args = 0;
		              
		               if ($args =~ m@<(.*?)>@s)
	                     {
		                  $tagname = $1; 
		                  
		                  if ($args =~ m@<$tagname>(.*?)</$tagname>@s)
		                    {
			                 $this_arg = $1;
			      
			                 $object_args.= " $tagname=\"$this_arg\"";
			                            
			                 $find_more_args = 1;
			                }
		                    
		                  $args =~ s@<$tagname>$this_arg</$tagname>@@;  
	                     } 
	                 }   
	               
	            $object_code = "<$type$object_args>$contents</$type>";
	  	                 
	            while ( my ($key, $value) = each(%$handed_object_args) ) 
	                 {
                      $object_code =~ s@<$key/>@$value@g;
                     }     
	                 
	            
	            $actionFile =~ s@<$object$raw_object_args>$object_contents</$object>@$object_code@;   	     
	            $rescan = 1;
               }
          }
     }
  
################################################################
#
#  Main Parser 
#  loads the action specified in query data, scans for commands
#  runs the appropriate plugins and builds the output
# 
################################################################
    
#load the action file specified in the query data
my $redo = 1; # set the redo flag, the command parser will reiterate while this is set
my $rescan = 1; # ser rescan flag, this can be tripped by a plugin such as <insertfile> to restart parsing 

while ($rescan)
  { 
   $rescan = 0;	  
   $redo = 1;

   #print "$actionFile\n\n\n\n\n\n\n\n\n\n\n";
   
while ($redo) #scan for () commands
 {
  $redo = 0;
  
  foreach $command (@commands)
   {
	if ($debugcmds) { print "scanning for ($command)\n"; } 
	   
	  $break = 0;	
      while (($actionFile =~ m@<lftbrk/>$command(.*?)<rtbrk/>(.*?)<lftbrk/>/$command<rtbrk/>@s)&&($break eq 0)&&($rescan eq 0))
        {
	     my $raw_command_args = $1;
	     my $command_contents = $2;
	     foreach $sub_command (@commands)
	        {
		     if ($command_contents =~ m@<lftbrk/>$sub_command(.*?)<rtbrk/>@s)
	           {
		        if ($sub_command eq $command)
		          {
			       $command_contents .= "<lftbrk/>/$command<rtbrk/>";
		           if ($command_contents =~ m@.*<lftbrk/>$command(.*?)<rtbrk/>(.*?)<lftbrk/>/$command<rtbrk/>$@s)
		             {
			          $raw_command_args = $1;   
			          $command_contents = $2;
		             }
		          }
	            else
	              {  
		           $redo = 1;
		           $break = 1;
	              }   
               }
            }
        
           if ($break eq 0)  
             { 
	          $data = $command_contents;
	          
	          if ($debugcmds) { print "running $command\n\n "; }
	          if ($logcmds) { $log .= "ran ($command)\n"; }

	          $result = "aXML error : command $command not found, or malformed args";       
	          
	          my $command_args;
	          
	          my @raw_command_args = split / /,$raw_command_args;
	          foreach $raw_command_arg (@raw_command_args)
	            {
		         if ($raw_command_arg =~ m@(.*?)="(.*?)"@s)
		           {
			        $command_args->{$1} = $2;
			        if ($debugcmds) { print "$1 = $command_args->{$1}\n"; }
	               }
	            }     
	          	            
	          if ($debugcmds) { print "command contents = $data\n\n\n\n"; }
	            	          
	          eval ( $plugins->{$command} ); 
	          
	          $result =~ s@\[@<lftsqbrk/>@g;
              $result =~ s@\]@<rtsqbrk/>@g;
              $result =~ s@\(@<lftbrk/>@g;
              $result =~ s@\)@<rtbrk/>@g;
              $result =~ s@\+@<plus/>@g;
                 	       	 
              if ($debugcmds) {  print "result = $result\n\n\n\n";  }
              if ($logcmds)   {  $log .= "command result = $result \n\n\n\n"; } 
              
	          $actionFile =~ s@<lftbrk/>$command$raw_command_args<rtbrk/>$command_contents<lftbrk/>/$command<rtbrk/>@$result@s;
              
              if ($debugcmds) { print "document now reads: \n\n $actionFile  \n\n\n\n" };
             }
          }            
       }   
   }  
  
$redo = 1; # set the redo flag, the command parser will reiterate while this is set

while ($redo)   #scan for <> commands
 {
  $redo = 0;
  foreach $command (@commands)
   {
	if ($debugcmds) { print "scanning for <$command>\n"; }
	   
	  $break = 0;
      while (($actionFile =~ m@<$command(.*?)>(.*?)<\/$command>@s)&&($break eq 0)&&($rescan eq 0))
        {
	     my $raw_command_args = $1;   
	     my $command_contents = $2;
	     foreach $sub_command (@commands)
	        {
		     if ($command_contents =~ m@<$sub_command(.*?)>@s)
	           {
		        if ($sub_command eq $command)
		          {
			       $command_contents .= "</$command>";
		           if ($command_contents =~ m@.*<$command(.*?)>(.*?)<\/$command>$@s)
		             {
			          $raw_command_args = $1;     
			          $command_contents = $2;
		             }
		          }
	            else
	              {  
		           $redo = 1;
		           $break = 1;
	              }   
               }
            }
        
           if ($break eq 0)  
             { 
	          $data = $command_contents;
	          
	          if ($debugcmds) { print "running $command\n\n "; }
              if ($logcmds) { $log .= "ran <$command>\n"; }
	          
	          $result = "aXML error : command $command not found, or malformed args";  
	
	          my $command_args;
	         	          
	          my @raw_command_args = split / /,$raw_command_args;             
              foreach $raw_command_arg (@raw_command_args)
	            {
		         if ($raw_command_arg =~ m@(.*?)="(.*?)"@s)
		           {
			        $command_args->{$1} = $2;
			        if ($debugcmds) { print "$1 = $command_args->{$1}\n"; }
	               }
	            }    
	           
	          if ($debugcmds) { print "command contents = $data\n\n\n\n"; }  
	                
	          eval ( $plugins->{$command} ); 
              
	          $result =~ s@\[@<lftsqbrk/>@g;
              $result =~ s@\]@<rtsqbrk/>@g;
              $result =~ s@\(@<lftbrk/>@g;
              $result =~ s@\)@<rtbrk/>@g;
              $result =~ s@\+@<plus/>@g;
                 	          
              if ($debugcmds) { print "result = $result\n\n\n\n"; }
              if ($logcmds)   {  $log .= "command result = $result \n\n\n\n"; } 
              
	          $actionFile =~ s@<$command$raw_command_args>$command_contents<\/$command>@$result@s;
              
              if ($debugcmds) { print "document now reads: \n\n $actionFile  \n\n\n\n" };
             }
          }            
       }
    }  
 }
    
 
#scan for remaining [ ] tags 
 
$redo = 1; # set the redo flag, the command parser will reiterate while this is set

while ($redo)   
 {
  $redo = 0;
  foreach $command (@commands)
   {
	if ($debugcmds) { print "scanning for [$command]\n"; }
	   
	  $break = 0;
      while (($actionFile =~ m@<lftsqbrk/>$command(.*?)<rtsqbrk/>(.*?)<lftsqbrk/>/$command<rtsqbrk/>@s)&&($break eq 0)&&($rescan eq 0))
        {
	     my $raw_command_args = $1;
	     my $command_contents = $2;
	     foreach $sub_command (@commands)
	        {
		     if ($command_contents =~ m@<lftsqbrk/>$sub_command(.*?)<rtsqbrk/>@s)
	           {
		        if ($sub_command eq $command)
		          {
			       $command_contents .= "\/$command\<rtsqbrk/>";
		           if ($command_contents =~ m@.*<lftsqbrk(.*?)/>$command<rtsqbrk/>(.*?)<lftsqbrk/>/$command<rtsqbrk/>$@s)
		             {
			          $raw_command_args = $1;
			          $command_contents = $2;
		             }
		          }
	            else
	              {  
		           $redo = 1;
		           $break = 1;
	              }   
               }
            }
        
           if ($break eq 0)  
             { 
	          $data = $command_contents;
	          
	          if ($debugcmds) { print "running $command\n\n "; }
	          if ($logcmds) { $log .= "ran [$command]\n"; }
	          
	          $result = "aXML error : command $command not found, or malformed args";  
	
	          my $command_args;
	         	          
	          my @raw_command_args = split / /,$raw_command_args;             
              foreach $raw_command_arg (@raw_command_args)
	            {
		         if ($raw_command_arg =~ m@(.*?)="(.*?)"@s)
		           {
			        $command_args->{$1} = $2;
			        if ($debugcmds) { print "$1 = $command_args->{$1}\n"; }
	               }
	            }    
	           
	          if ($debugcmds) { print "command contents = $data\n\n\n\n"; }  
              if ($logcmds)   {  $log .= "command result = $result \n\n\n\n"; } 
	          	                    
	          eval ( $plugins->{$command} ); 
              	               
	          $result =~ s@\[@<lftsqbrk/>@g;
              $result =~ s@\]@<rtsqbrk/>@g;
              $result =~ s@\(@<lftbrk/>@g;
              $result =~ s@\)@<rtbrk/>@g;
              $result =~ s@\+@<plus/>@g;
                 	          
              if ($debugcmds) { print "result = $result\n\n\n\n"; }
                   
	          $actionFile =~ s@<lftsqbrk/>$command$raw_command_args<rtsqbrk/>$command_contents<lftsqbrk/>/$command<rtsqbrk/>@$result@s;
                  
              if ($debugcmds) { print "document now reads: \n\n $actionFile  \n\n\n\n" };
             }
          }            
       }
    }   
 
################################################################
#
#  Clean up and output 
#  final modifications to the remaining document
#  inserts files that are not to be processed
# 
################################################################  

while ($actionFile =~ m@<editfile>(.*?)</editfile>@s)
     {
 	  $edit_filename = $1;
 	  my $editFile = getFile("$ENV{DOCUMENT_ROOT}/$edit_filename");  
 	  $actionFile =~ s@<editfile>$edit_filename</editfile>@$editFile@gs;
     }     
 
$actionFile =~ s@<currentuser/>@$username@g;  
$actionFile =~ s@<userlevel/>@$userlevel@g;  
$actionFile =~ s@<ques/>@\?@gs; 
$actionFile =~ s@<lftbrk/>@\(@g;  
$actionFile =~ s@<rtbrk/>@\)@g;  
$actionFile =~ s@<lftsqbrk/>@\[@g;  
$actionFile =~ s@<rtsqbrk/>@\]@g;  
$actionFile =~ s@<plus/>@\+@g;


if ($qd->{gettype} eq "html") { print "Content-type: text/html\n\n";  }
if ($qd->{gettype} eq "axml") { print "Content-type: text/axml\n\n";  }

print $actionFile;

################################################################
#
#  Save Logging file 
#  if logcmds flag set, write new log file
# 
################################################################

if ($logcmds) 
  {
   writeFile("<filename>logs/$qd->{action}.log</filename>
               <data>$log</data>");
  }