Annotation of loncom/build/xfml_parse.pl, revision 1.4
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: #
! 11: # $Id: piml_parse.pl,v 1.5 2002/02/05 01:49:39 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: #
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:
! 330: xfml_parse.pl - This is meant to parse files meeting the xfml document type.
! 331: See xfml.dtd. XFML=XML Filtering Markup Language.
! 332:
! 333: =head1 SYNOPSIS
! 334:
! 335: Usage is for lpml file to come in through standard input.
! 336:
! 337: =over 4
! 338:
! 339: =item *
! 340:
! 341: 1st argument is name of xfml file.
! 342:
! 343: =back
! 344:
! 345: Example:
! 346:
! 347: cat loncapafiles.lpml | perl xfml_parse.pl valid_hosts.xfml
! 348:
! 349: or
! 350:
! 351: perl xfml_parse.pl valid_hosts.xfml loncapafiles.lpml
! 352:
! 353: =head1 DESCRIPTION
! 354:
! 355: I am using a multiple pass-through approach to parsing
! 356: the xfml file. This saves memory and makes sure the server
! 357: will never be overloaded.
! 358:
! 359: =head1 README
! 360:
! 361: I am using a multiple pass-through approach to parsing
! 362: the xfml file. This saves memory and makes sure the server
! 363: will never be overloaded.
! 364:
! 365: =head1 PREREQUISITES
! 366:
! 367: HTML::TokeParser
! 368:
! 369: =head1 COREQUISITES
! 370:
! 371: =head1 OSNAMES
! 372:
! 373: linux
! 374:
! 375: =head1 SCRIPT CATEGORIES
! 376:
! 377: Packaging/Administrative
! 378:
! 379: =head1 AUTHOR
! 380:
! 381: Scott Harrison
! 382: codeharrison@yahoo.com
! 383:
! 384: Please let me know how/if you are finding this script useful and
! 385: any/all suggestions. -Scott
! 386:
! 387: =cut
! 388:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to xfml_parse.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / build