Annotation of loncom/build/xfml_parse.pl, revision 1.5

1.1       harris41    1: #!/usr/bin/perl
                      2: 
1.4       harris41    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: #
1.5     ! harris41   11: # $Id: xfml_parse.pl,v 1.4 2002/04/08 10:52:24 harris41 Exp $
1.4       harris41   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: #
1.1       harris41   37: # YEAR=2002
1.4       harris41   38: # 1/26,1/27,1/28,1/29,1/30,1/31,2/20,4/8 - Scott Harrison
1.2       harris41   39: #
                     40: ###
1.1       harris41   41: 
                     42: # Read in 2 XML file; first is the filter specification, the second
                     43: # is the XML file to be filtered
                     44: 
1.2       harris41   45: ###############################################################################
                     46: ##                                                                           ##
                     47: ## ORGANIZATION OF THIS PERL SCRIPT                                          ##
                     48: ## 1. Notes                                                                  ##
1.3       harris41   49: ## 2. Read in filter file                                                    ##
                     50: ## 3. Initialize and clear conditions                                        ##
                     51: ## 4. Run through and apply clauses                                          ##
1.2       harris41   52: ##                                                                           ##
                     53: ###############################################################################
                     54: 
                     55: # ----------------------------------------------------------------------- Notes
                     56: #
1.3       harris41   57: # This is meant to parse files meeting the xfml document type.
1.2       harris41   58: # See xfml.dtd.  XFML=XML Filtering Markup Language.
                     59: 
1.1       harris41   60: use HTML::TokeParser;
                     61: use strict;
                     62: 
                     63: unless (@ARGV) {
1.4       harris41   64:     print(<<END);
1.1       harris41   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;
1.3       harris41   73: 
                     74: # ---------------------------------------------- Read in filter file from @ARGV
1.1       harris41   75: my $tofilter=shift @ARGV;
1.4       harris41   76: open(IN,"<$tofilter"); my @lines=<IN>;
1.3       harris41   77: my $parsestring=join('',@lines); undef @lines; close IN;
1.1       harris41   78: my $parser = HTML::TokeParser->new(\$parsestring) or
                     79:     die('can\'t create TokeParser object');
                     80: $parser->xml_mode('1');
                     81: 
1.3       harris41   82: # --------------------------------------------- initialize and clear conditions
1.1       harris41   83: my %conditions; &cc;
                     84: 
1.3       harris41   85: # Define handling methods for mode-dependent text rendering
1.1       harris41   86: $parser->{textify}={
1.3       harris41   87:     'xfml' => \&format_xfml,
1.1       harris41   88:     'when:name' => \&format_when_name,
                     89:     'when:attribute' => \&format_when_attribute,
                     90:     'when:cdata' => \&format_when_cdata,
                     91:     'choice:exclude' => \&format_choice_exclude,
1.3       harris41   92:     'clause' => \&format_clause,
1.1       harris41   93:     };
                     94: 
                     95: my $text;
                     96: my $xfml;
                     97: my $wloc=0;
                     98: my %eha;
                     99: 
1.3       harris41  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;
1.1       harris41  170: }
1.3       harris41  171: print $output;
1.1       harris41  172: 
1.3       harris41  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;
1.1       harris41  180:     }
1.3       harris41  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;
1.1       harris41  199: 		}
                    200: 	    }
1.3       harris41  201: 	    $Ttoken='';
1.1       harris41  202: 	}
1.3       harris41  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;
1.1       harris41  221: 			}
1.3       harris41  222: 			$match=~s/^\///g;
                    223: 			$match=~s/\/$//g;
                    224: 			if ((!$flag and $Ttoken=~/$match/) or
                    225: 			    ($flag and $Ttoken!~/$match/)) {
                    226: 			    $cdataflag=1;
1.2       harris41  227: 			}
1.3       harris41  228: 		    }
                    229: 		    if (@{$conditions{'cdata'}}) {
                    230: 			if ($cdataflag) {
                    231: 			    return 0;
1.1       harris41  232: 			}
1.3       harris41  233: 		    }
                    234: 		    else {
                    235: 			if ($nameflag) {
                    236: 			    return 0;
1.1       harris41  237: 			}
                    238: 		    }
1.3       harris41  239: 		    $nameflag=0;
1.1       harris41  240: 		}
                    241: 	    }
                    242: 	}
1.3       harris41  243: 	elsif ($token->[0] eq 'T') {
                    244: 	    if ($nameflag) {
                    245: 		$Ttoken.=$token->[1];
1.1       harris41  246: 	    }
                    247: 	}
                    248:     }
1.3       harris41  249:     return 1;
1.1       harris41  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'}};
1.3       harris41  258:     %eh=(1,1); delete $eh{1};
1.1       harris41  259: }
                    260: 
                    261: # --------------------------------------- remove starting and ending whitespace
                    262: sub trim {
                    263:     my ($s)=@_; $s=~s/^\s*//; $s=~s/\s*$//; return $s;
                    264: }
                    265: 
1.2       harris41  266: 
                    267: 
1.3       harris41  268: 
1.1       harris41  269: # --------------------------------------------------------- Format xfml section
                    270: sub format_xfml {
                    271:     my (@tokeninfo)=@_;
                    272:     return '';
                    273: }
                    274: 
1.3       harris41  275: # ------------------------------------------------------- Format clause section
                    276: sub format_clause {
                    277:     my (@tokeninfo)=@_;
                    278:     return '';
                    279: }
                    280: 
1.1       harris41  281: # ---------------------------------------------------- Format when:name section
                    282: sub format_when_name {
                    283:     my (@tokeninfo)=@_;
1.3       harris41  284: #    $wloc++;
1.1       harris41  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');
1.3       harris41  289: #    $wloc--;
                    290: #    &cc unless $wloc;
1.1       harris41  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--;
1.3       harris41  303: #    &cc unless $wloc;
1.1       harris41  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: }
1.4       harris41  323: 
                    324: # ----------------------------------- POD (plain old documentation, CPAN style)
                    325: 
                    326: =pod
                    327: 
                    328: =head1 NAME
                    329: 
1.5     ! harris41  330: xfml_parse.pl - This is meant to parse XFML files (XML Filtering Markup Language.)
1.4       harris41  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: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>