Return to xfml_parse.pl CVS log

Up to [LON-CAPA] / loncom / build

xfml_parse.pl already has been well-tested.  the changes in 1.6 are incorrect
and are now reversed.

    1: #!/usr/bin/perl
    2: 
    3: # -------------------------------------------------------- Documentation notice
    4: # Run "perldoc ./lpml_parse.pl" in order to best view the software
    5: # documentation internalized in this program.
    6: 
    7: # --------------------------------------------------------- License Information
    8: # The LearningOnline Network with CAPA
    9: # piml_parse.pl - Linux Packaging Markup Language parser
   10: #
   11: # $Id: xfml_parse.pl,v 1.7 2002/05/22 17:07:50 harris41 Exp $
   12: #
   13: # Written by Scott Harrison, codeharrison@yahoo.com
   14: #
   15: # Copyright Michigan State University Board of Trustees
   16: #
   17: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   18: #
   19: # LON-CAPA is free software; you can redistribute it and/or modify
   20: # it under the terms of the GNU General Public License as published by
   21: # the Free Software Foundation; either version 2 of the License, or
   22: # (at your option) any later version.
   23: #
   24: # LON-CAPA is distributed in the hope that it will be useful,
   25: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   26: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   27: # GNU General Public License for more details.
   28: #
   29: # You should have received a copy of the GNU General Public License
   30: # along with LON-CAPA; if not, write to the Free Software
   31: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   32: #
   33: # /home/httpd/html/adm/gpl.txt
   34: #
   35: # http://www.lon-capa.org/
   36: #
   37: # YEAR=2002
   38: # 1/26,1/27,1/28,1/29,1/30,1/31,2/20,4/8 - Scott Harrison
   39: #
   40: ###
   41: 
   42: # Read in 2 XML file; first is the filter specification, the second
   43: # is the XML file to be filtered
   44: 
   45: ###############################################################################
   46: ##                                                                           ##
   47: ## ORGANIZATION OF THIS PERL SCRIPT                                          ##
   48: ## 1. Notes                                                                  ##
   49: ## 2. Read in filter file                                                    ##
   50: ## 3. Initialize and clear conditions                                        ##
   51: ## 4. Run through and apply clauses                                          ##
   52: ##                                                                           ##
   53: ###############################################################################
   54: 
   55: # ----------------------------------------------------------------------- Notes
   56: #
   57: # This is meant to parse files meeting the xfml document type.
   58: # See xfml.dtd.  XFML=XML Filtering Markup Language.
   59: 
   60: use HTML::TokeParser;
   61: use strict;
   62: 
   63: unless (@ARGV) {
   64:     print(<<END);
   65: Incorrect invocation.
   66: Example usages:
   67: cat loncapafiles.lpml | perl xfml_parse.pl valid_hosts.xfml
   68: perl xfml_parse.pl valid_hosts.xfml loncapafiles.lpml
   69: END
   70: }
   71: 
   72: my %eh;
   73: 
   74: # ---------------------------------------------- Read in filter file from @ARGV
   75: my $tofilter=shift @ARGV;
   76: open(IN,"<$tofilter"); my @lines=<IN>;
   77: my $parsestring=join('',@lines); undef @lines; close IN;
   78: my $parser = HTML::TokeParser->new(\$parsestring) or
   79:     die('can\'t create TokeParser object');
   80: $parser->xml_mode('1');
   81: 
   82: # --------------------------------------------- initialize and clear conditions
   83: my %conditions; &cc;
   84: 
   85: # Define handling methods for mode-dependent text rendering
   86: $parser->{textify}={
   87:     'xfml' => \&format_xfml,
   88:     'when:name' => \&format_when_name,
   89:     'when:attribute' => \&format_when_attribute,
   90:     'when:cdata' => \&format_when_cdata,
   91:     'choice:exclude' => \&format_choice_exclude,
   92:     'clause' => \&format_clause,
   93:     };
   94: 
   95: my $text;
   96: my $xfml;
   97: my $wloc=0;
   98: my %eha;
   99: 
  100: # ----------------------------------------------- Run through and apply clauses
  101: my @lines2=<>; my $output=join('',@lines2); undef @lines2;
  102: my $lparser = HTML::TokeParser->new(\$output) or
  103:     die('can\'t create TokeParser object');
  104: $lparser->xml_mode('1');
  105: my $parsestring2;
  106: while (my $token = $parser->get_tag('clause')) {
  107:     $parsestring2=$output;
  108:     $lparser = HTML::TokeParser->new(\$parsestring2);
  109:     $lparser->xml_mode('1');
  110:     $output='';
  111:     &format_clause(@{$token});
  112:     $text = $parser->get_text('/clause');
  113:     $token = $parser->get_tag('/clause');
  114: 
  115:     my $token='';
  116:     my $ttype='';
  117:     my $excludeflag=0;
  118:     my $outcache='';
  119:     while ($token = $lparser->get_token()) {
  120: 	if ($token->[0] eq 'D') { $ttype='D'; $output.=$token->[1]; }
  121: 	elsif ($token->[0] eq 'C') { $ttype='C'; $output.=$token->[1];	}
  122: 	elsif ($token->[0] eq 'T') {
  123: 	    if ($ttype eq 'D' or $ttype eq 'C' or $ttype eq 'S'
  124: 		or $ttype eq 'E') {
  125: 		$output.=$token->[1];
  126: 	    }
  127: 	    else {
  128: 		$outcache.=$token->[1];
  129: 	    }
  130: 	}
  131: 	elsif ($token->[0] eq 'S') {
  132: 	    if ($eh{$token->[1]} or $excludeflag==1) {
  133: 		$ttype='';
  134: 		$excludeflag=1;
  135: 		$outcache.=$token->[4];
  136: 	    }
  137: 	    else {
  138: 		$ttype='S';
  139: 		$output.=$token->[4];
  140: 	    }
  141: 	    if ($excludeflag==1) {
  142: 		
  143: 	    }
  144: 	}
  145: 	elsif ($token->[0] eq 'E') {
  146: 	    if ($eh{$token->[1]} and $excludeflag==1) {
  147: 		$ttype='E';
  148: 		$excludeflag=0;
  149: 		$outcache.=$token->[2];
  150: 		my $retval=&evalconditions($outcache);
  151: 		if (&evalconditions($outcache)) {
  152: 		    $output.=$outcache;
  153: 		}
  154: 		else {
  155: 		    $output.='<!-- FILTERED OUT -->';
  156: 		}
  157: 		$outcache='';
  158: 	    }
  159: 	    elsif ($excludeflag==1) {
  160: 		$ttype='';
  161: 		$outcache.=$token->[2];
  162: 	    }
  163: 	    else {
  164: 		$output.=$token->[2];
  165: 		$ttype='E';
  166: 	    }
  167: 	}
  168:     }
  169:     &cc;
  170: }
  171: print $output;
  172: 
  173: # -------------------------------------------------------------- evalconditions
  174: sub evalconditions {
  175:     my ($parsetext)=@_;
  176:     my $eparser = HTML::TokeParser->new(\$parsetext);
  177:     unless (@{$conditions{'name'}} or
  178: 	    @{$conditions{'attribute'}}) {
  179: 	return 0;
  180:     }
  181:     my $nameflag=0;
  182:     my $cdataflag=0;
  183:     my $matchflag=0;
  184:     my $Ttoken='';
  185:     while (my $token = $eparser->get_token()) {
  186: 	if ($token->[0] eq 'S') {
  187: 	    foreach my $name (@{$conditions{'name'}}) {
  188: 		my $flag=0;
  189: 		my $match=$name;
  190: 		if ($match=~/^\!/) {
  191: 		    $match=~s/^\!//g;
  192: 		    $flag=1;
  193: 		}
  194: 		$match=~s/^\///g;
  195: 		$match=~s/\/$//g;
  196: 		if ((!$flag and $token->[1]=~/$match/) or
  197: 		    ($flag and $token->[1]!~/$match/)) {
  198: 		    $nameflag=1;
  199: 		}
  200: 	    }
  201: 	    $Ttoken='';
  202: 	}
  203: 	elsif ($token->[0] eq 'E') {
  204: 	    foreach my $name (@{$conditions{'name'}}) {
  205: 		my $flag=0;
  206: 		my $match=$name;
  207: 		if ($match=~/^\!/) {
  208: 		    $match=~s/^\!//g;
  209: 		    $flag=1;
  210: 		}
  211: 		$match=~s/^\///g;
  212: 		$match=~s/\/$//g;
  213: 		if ((!$flag and $token->[1]=~/$match/) or
  214: 		    ($flag and $token->[1]!~/$match/)) {
  215: 		    foreach my $cdata (@{$conditions{'cdata'}}) {
  216: 			my $flag=0;
  217: 			my $match=$cdata;
  218: 			if ($match=~/^\!/) {
  219: 			    $match=~s/^\!//g;
  220: 			    $flag=1;
  221: 			}
  222: 			$match=~s/^\///g;
  223: 			$match=~s/\/$//g;
  224: 			if ((!$flag and $Ttoken=~/$match/) or
  225: 			    ($flag and $Ttoken!~/$match/)) {
  226: 			    $cdataflag=1;
  227: 			}
  228: 		    }
  229: 		    if (@{$conditions{'cdata'}}) {
  230: 			if ($cdataflag) {
  231: 			    return 0;
  232: 			}
  233: 		    }
  234: 		    else {
  235: 			if ($nameflag) {
  236: 			    return 0;
  237: 			}
  238: 		    }
  239: 		    $nameflag=0;
  240: 		}
  241: 	    }
  242: 	}
  243: 	elsif ($token->[0] eq 'T') {
  244: 	    if ($nameflag) {
  245: 		$Ttoken.=$token->[1];
  246: 	    }
  247: 	}
  248:     }
  249:     return 1;
  250: }
  251: 
  252: # ------------------------------------------------------------ clear conditions
  253: sub cc {
  254:     @{$conditions{'name'}}=(); pop @{$conditions{'name'}};
  255:     @{$conditions{'attribute'}}=(); pop @{$conditions{'attribute'}};
  256:     @{$conditions{'value'}}=(); pop @{$conditions{'value'}};
  257:     @{$conditions{'cdata'}}=(); pop @{$conditions{'cdata'}};
  258:     %eh=(1,1); delete $eh{1};
  259: }
  260: 
  261: # --------------------------------------- remove starting and ending whitespace
  262: sub trim {
  263:     my ($s)=@_; $s=~s/^\s*//; $s=~s/\s*$//; return $s;
  264: }
  265: 
  266: 
  267: 
  268: 
  269: # --------------------------------------------------------- Format xfml section
  270: sub format_xfml {
  271:     my (@tokeninfo)=@_;
  272:     return '';
  273: }
  274: 
  275: # ------------------------------------------------------- Format clause section
  276: sub format_clause {
  277:     my (@tokeninfo)=@_;
  278:     return '';
  279: }
  280: 
  281: # ---------------------------------------------------- Format when:name section
  282: sub format_when_name {
  283:     my (@tokeninfo)=@_;
  284: #    $wloc++;
  285:     my $att_match=$tokeninfo[2]->{'match'};
  286:     push @{$conditions{'name'}},$att_match;
  287:     my $text=&trim($parser->get_text('/when:name'));
  288:     $parser->get_tag('/when:name');
  289: #    $wloc--;
  290: #    &cc unless $wloc;
  291:     return '';
  292: }
  293: 
  294: # --------------------------------------------------- Format when:cdata section
  295: sub format_when_cdata {
  296:     my (@tokeninfo)=@_;
  297:     $wloc++;
  298:     my $att_match=$tokeninfo[2]->{'match'};
  299:     push @{$conditions{'cdata'}},$att_match;
  300:     my $text=&trim($parser->get_text('/when:cdata'));
  301:     $parser->get_tag('/when:cdata');
  302:     $wloc--;
  303: #    &cc unless $wloc;
  304:     return '';
  305: }
  306: 
  307: # ----------------------------------------------- Format choice:exclude section
  308: sub format_choice_exclude {
  309:     my (@tokeninfo)=@_;
  310:     my $text=&trim($parser->get_text('/choice:exclude'));
  311:     $parser->get_tag('/choice:exclude');
  312:     $eh{$tokeninfo[2]->{'nodename'}}++;
  313:     push @{$eha{$tokeninfo[2]->{'nodename'}}->{'name'}},
  314:          [@{$conditions{'name'}}];
  315:     push @{$eha{$tokeninfo[2]->{'nodename'}}->{'attribute'}},
  316:          [@{$conditions{'attribute'}}];
  317:     push @{$eha{$tokeninfo[2]->{'nodename'}}->{'value'}},
  318:          [@{$conditions{'value'}}];
  319:     push @{$eha{$tokeninfo[2]->{'nodename'}}->{'cdata'}},
  320:          [@{$conditions{'cdata'}}];
  321:     return '';
  322: }
  323: 
  324: # ----------------------------------- POD (plain old documentation, CPAN style)
  325: 
  326: =pod
  327: 
  328: =head1 NAME
  329: 
  330: xfml_parse.pl - This is meant to parse XFML files (XML Filtering Markup Language.)
  331: 
  332: =head1 SYNOPSIS
  333: 
  334: Usage is for lpml file to come in through standard input.
  335: 
  336: =over 4
  337: 
  338: =item * 
  339: 
  340: 1st argument is name of xfml file.
  341: 
  342: =back
  343: 
  344: Example:
  345: 
  346:  cat loncapafiles.lpml | perl xfml_parse.pl valid_hosts.xfml
  347: 
  348: or
  349: 
  350:  perl xfml_parse.pl valid_hosts.xfml loncapafiles.lpml
  351: 
  352: =head1 DESCRIPTION
  353: 
  354: I am using a multiple pass-through approach to parsing
  355: the xfml file.  This saves memory and makes sure the server
  356: will never be overloaded.
  357: 
  358: =head1 README
  359: 
  360: I am using a multiple pass-through approach to parsing
  361: the xfml file.  This saves memory and makes sure the server
  362: will never be overloaded.
  363: 
  364: =head1 PREREQUISITES
  365: 
  366: HTML::TokeParser
  367: 
  368: =head1 COREQUISITES
  369: 
  370: =head1 OSNAMES
  371: 
  372: linux
  373: 
  374: =head1 SCRIPT CATEGORIES
  375: 
  376: Packaging/Administrative
  377: 
  378: =head1 AUTHOR
  379: 
  380:  Scott Harrison
  381:  codeharrison@yahoo.com
  382: 
  383: Please let me know how/if you are finding this script useful and
  384: any/all suggestions.  -Scott
  385: 
  386: =cut
  387: