simonodell1 has asked for the wisdom of the Perl Monks concerning the following question:
ok im sure most of you could write this better, im working on this, and its the first time ive shown anyone so be nice :)
#!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: t +ext/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/$currentI +P.xml")) { if ($session_info =~ m@<username>(.*?)</username>@s) { $username + = $1; } if ($session_info =~ m@<userlevel>(.*?)</userlevel>@s) { $userle +vel = $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}.aX +ML"); #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 $ra +w_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_cont +ents</$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 w +hile this is set my $rescan = 1; # ser rescan flag, this can be tripped by a plugin suc +h 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/>(.*?)<lft +brk/>/$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(.*?)<rtb +rk/>@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 m +alformed 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<rtbr +k/>$command_contents<lftbrk/>/$command<rtbrk/>@$result@s; if ($debugcmds) { print "document now reads: \n\n $actio +nFile \n\n\n\n" }; } } } } $redo = 1; # set the redo flag, the command parser will reiterate whil +e 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 m +alformed 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_con +tents<\/$command>@$result@s; if ($debugcmds) { print "document now reads: \n\n $actio +nFile \n\n\n\n" }; } } } } } #scan for remaining [ ] tags $redo = 1; # set the redo flag, the command parser will reiterate whil +e 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(.*?)<r +tsqbrk/>@s) { if ($sub_command eq $command) { $command_contents .= "\/$command\<rtsqbrk/>"; if ($command_contents =~ m@.*<lftsqbrk(.*?)/>$comma +nd<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 m +alformed 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<rt +sqbrk/>$command_contents<lftsqbrk/>/$command<rtsqbrk/>@$result@s; if ($debugcmds) { print "document now reads: \n\n $actio +nFile \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>"); }
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re: the axml parser v3.4
by GrandFather (Saint) on Apr 12, 2007 at 08:05 UTC | |
|
Re: the axml parser v3.4
by gloryhack (Deacon) on Apr 12, 2007 at 09:05 UTC | |
|
Re: the axml parser v3.4
by jdporter (Paladin) on Apr 12, 2007 at 18:32 UTC | |
by parv (Parson) on Apr 13, 2007 at 22:16 UTC | |
by injunjoel (Priest) on Apr 30, 2007 at 17:38 UTC | |
|
Re: the axml parser v3.4
by Jenda (Abbot) on Apr 12, 2007 at 10:41 UTC | |
by simonodell1 (Novice) on Apr 12, 2007 at 11:44 UTC | |
by jdporter (Paladin) on Apr 13, 2007 at 16:04 UTC | |
by Jenda (Abbot) on Apr 13, 2007 at 15:03 UTC | |
by Anonymous Monk on Apr 12, 2007 at 17:31 UTC | |
|
Re: the axml parser v3.4
by Mr. Muskrat (Canon) on Apr 12, 2007 at 18:03 UTC | |
|
Re: the axml parser v3.4
by robot_tourist (Hermit) on Apr 12, 2007 at 09:08 UTC |