Return to piml_parse.pl CVS log

Up to [LON-CAPA] / loncom / build

- adding <DIST /> as a tag possibility for the body of a <perlscript> (Well for inside any tag really)

    1: #!/usr/bin/perl
    2: 
    3: # -------------------------------------------------------- Documentation notice
    4: # Run "perldoc ./piml_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.11 2005/10/05 18:37:03 albertel 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/28,1/29,1/30,1/31,2/5,4/8 - Scott Harrison
   39: #
   40: ###
   41: 
   42: ###############################################################################
   43: ##                                                                           ##
   44: ## ORGANIZATION OF THIS PERL SCRIPT                                          ##
   45: ## 1. Notes                                                                  ##
   46: ## 2. Get command line arguments                                             ##
   47: ## 3. First pass through (grab distribution-specific information)            ##
   48: ## 4. Second pass through (parse out what is not necessary)                  ##
   49: ## 5. Third pass through (translate markup according to specified mode)      ##
   50: ## 6. Functions (most all just format contents of different markup tags)     ##
   51: ## 7. POD (plain old documentation, CPAN style)                              ##
   52: ##                                                                           ##
   53: ###############################################################################
   54: 
   55: # ----------------------------------------------------------------------- Notes
   56: #
   57: # I am using a multiple pass-through approach to parsing
   58: # the piml file.  This saves memory and makes sure the server
   59: # will never be overloaded.
   60: #
   61: # This is meant to parse files meeting the piml document type.
   62: # See piml.dtd.  PIML=Post Installation Markup Language.
   63: 
   64: # To reduce system dependencies, I'm using a lightweight
   65: # parser.  At some point, I need to get serious with a
   66: # better xml parsing engine and stylesheet usage.
   67: use HTML::TokeParser;
   68: 
   69: my $usage=(<<END);
   70: **** ERROR ERROR ERROR ERROR ****
   71: Usage is for piml file to come in through standard input.
   72: 1st argument is the category permissions to use (runtime or development)
   73: 2nd argument is the distribution (default,redhat6,debian2.2,redhat7,etc).
   74: 3rd argument is to manually specify a targetroot
   75: 
   76: Only the 1st argument is mandatory for the program to run.
   77: 
   78: Example:
   79: 
   80: cat ../../doc/sanitycheck.piml |\\
   81: perl piml_parse.pl development default /home/sherbert/loncapa
   82: END
   83: 
   84: # ------------------------------------------------- Grab command line arguments
   85: 
   86: # If number of arguments is incorrect, then give up and print usage message.
   87: unless (@ARGV == 3)
   88:   {
   89:     @ARGV=();shift(@ARGV);
   90:     while(<>){} # throw away the input to avoid broken pipes
   91:     print($usage); # print usage message
   92:     exit -1; # exit with error status
   93:   }
   94: 
   95: my $categorytype;
   96: if (@ARGV)
   97:   {
   98:     $categorytype = shift(@ARGV);
   99:   }
  100: 
  101: my $dist;
  102: if (@ARGV)
  103:   {
  104:     $dist = shift(@ARGV);
  105:   }
  106: 
  107: my $targetroot;
  108: my $targetrootarg;
  109: if (@ARGV)
  110:   {
  111:     $targetroot = shift(@ARGV);
  112:   }
  113: 
  114: $targetroot=~s/\/$//;
  115: $targetrootarg=$targetroot;
  116: 
  117: my $logcmd='| tee -a WARNINGS';
  118: 
  119: my $invocation;
  120: # --------------------------------------------------- Record program invocation
  121: if ($mode eq 'install' or $mode eq 'configinstall' or $mode eq 'build')
  122:   {
  123:     $invocation=(<<END);
  124: # Invocation: STDINPUT | piml_parse.pl
  125: #             1st argument (category type) is: $categorytype
  126: #             2nd argument (distribution) is: $dist
  127: #             3rd argument (targetroot) is: described below
  128: END
  129:   }
  130: 
  131: # ---------------------------------------------------- Start first pass through
  132: my @parsecontents = <>;
  133: my $parsestring = join('',@parsecontents);
  134: my $outstring='';
  135: 
  136: # Need to make a pass through and figure out what defaults are
  137: # overrided.  Top-down overriding strategy (leaves don't know
  138: # about distant leaves).
  139: 
  140: my @hierarchy;
  141: $hierarchy[0]=0;
  142: my $hloc=0;
  143: my $token='';
  144: $parser = HTML::TokeParser->new(\$parsestring) or
  145:     die('can\'t create TokeParser object');
  146: $parser->xml_mode('1');
  147: my %hash;
  148: my $key;
  149: while ($token = $parser->get_token())
  150:   {
  151:     if ($token->[0] eq 'S')
  152:       {
  153: 	$hloc++;
  154: 	$hierarchy[$hloc]++;
  155: 	$key=$token->[1].join(',',@hierarchy[0..($hloc-1)]);
  156: 	my $thisdist=' '.$token->[2]{'dist'}.' ';
  157: 	if ($thisdist eq ' default ')
  158:           {
  159: 	    $hash{$key}=1; # there is a default setting for this key
  160: 	  }
  161: 	elsif ($dist && $hash{$key}==1 && $thisdist=~/\s$dist\s/)
  162:           {
  163: 	    $hash{$key}=2; # disregard default setting for this key if
  164: 	                   # there is a directly requested distribution match
  165: 	  }
  166:       }
  167:     if ($token->[0] eq 'E')
  168:       {
  169: 	$hloc--;
  170:       }
  171:   }
  172: 
  173: # --------------------------------------------------- Start second pass through
  174: undef $hloc;
  175: undef @hierarchy;
  176: undef $parser;
  177: $hierarchy[0]=0;
  178: $parser = HTML::TokeParser->new(\$parsestring) or
  179:     die('can\'t create TokeParser object');
  180: $parser->xml_mode('1');
  181: my $cleanstring;
  182: while ($token = $parser->get_token()) {
  183:     if ($token->[0] eq 'S') {
  184: 	$hloc++;
  185: 	$hierarchy[$hloc]++;
  186: 	$key=$token->[1].join(',',@hierarchy[0..($hloc-1)]);
  187: 	my $thisdist=' '.$token->[2]{'dist'}.' ';
  188: 	# This conditional clause is set up to ignore two sets
  189: 	# of invalid conditions before accepting entry into
  190: 	# the cleanstring.
  191: 	if ($hash{$key}==2 and
  192: 	    !($thisdist eq '  ' or $thisdist =~/\s$dist\s/)) {
  193: 	    if ($token->[4]!~/\/>$/) {
  194: 		$parser->get_tag('/'.$token->[1]);
  195: 		$hloc--;
  196: 	    }
  197: 	}
  198: 	elsif ($thisdist ne '  ' and $thisdist!~/\s$dist\s/ and
  199: 	       !($thisdist eq ' default ' and $hash{$key}!=2)) {
  200: 	    if ($token->[4]!~/\/>$/) {
  201: 		$parser->get_tag('/'.$token->[1]);
  202: 		$hloc--;
  203: 	    }
  204: 	}
  205: 	else {
  206: 	    $cleanstring.=$token->[4];
  207: 	}
  208: 	if ($token->[4]=~/\/>$/) {
  209: #	    $hloc--;
  210: 	}
  211:     }
  212:     if ($token->[0] eq 'E') {
  213: 	$cleanstring.=$token->[2];
  214: 	$hloc--;
  215:     }
  216:     if ($token->[0] eq 'T') {
  217: 	$cleanstring.=$token->[1];
  218:     }
  219: }
  220: $cleanstring=&trim($cleanstring);
  221: $cleanstring=~s/\>\s*\n\s*\</\>\</g;
  222: 
  223: # ---------------------------------------------------- Start final pass through
  224: 
  225: # storage variables
  226: my $piml;
  227: my $categories;
  228: my @categorynamelist;
  229: my $category;
  230: my $category_att_name;
  231: my $category_att_type;
  232: my $chown;
  233: my $chmod;
  234: my $abbreviation; # space-free abbreviation; esp. for image names
  235: my $categoryname;
  236: my $description;
  237: my $files;
  238: my $file;
  239: my $target;
  240: my $note;
  241: my $commands;
  242: my $command;
  243: my $dependencies;
  244: my @links;
  245: my %categoryhash;
  246: my $dpathlength;
  247: my %fab; # file category abbreviation
  248: my $directory_count;
  249: my $file_count;
  250: my $link_count;
  251: my $fileglob_count;
  252: my $fileglobnames_count;
  253: my %categorycount;
  254: 
  255: my $mode;
  256: 
  257: my @buildall;
  258: my @buildinfo;
  259: 
  260: my @configall;
  261: 
  262: # Make new parser with distribution specific input
  263: undef($parser);
  264: $parser = HTML::TokeParser->new(\$cleanstring) or
  265:     die('can\'t create TokeParser object');
  266: $parser->xml_mode('1');
  267: 
  268: # Define handling methods for mode-dependent text rendering
  269: 
  270: $parser->{textify}={
  271:     specialnotices => \&format_specialnotices,
  272:     specialnotice => \&format_specialnotice,
  273:     targetroot => \&format_targetroot,
  274:     categories => \&format_categories,
  275:     category => \&format_category,
  276:     abbreviation => \&format_abbreviation,
  277:     chown => \&format_chown,
  278:     chmod => \&format_chmod,
  279:     categoryname => \&format_categoryname,
  280:     files => \&format_files,
  281:     file => \&format_file,
  282:     target => \&format_target,
  283:     note => \&format_note,
  284:     build => \&format_build,
  285:     dependencies => \&format_dependencies,
  286:     filenames => \&format_filenames,
  287:     perlscript => \&format_perlscript,
  288:     TARGET => \&format_TARGET,
  289:     DIST => \&format_DIST,
  290:     };
  291: 
  292: my $text;
  293: my $token;
  294: undef($hloc);
  295: undef(@hierarchy);
  296: my $hloc;
  297: my @hierarchy2;
  298: while ($token = $parser->get_tag('piml'))
  299:   {
  300:     &format_piml(@{$token});
  301:     $text = &trim($parser->get_text('/piml'));
  302:     $token = $parser->get_tag('/piml');
  303:     print($piml); 
  304:     print("\n");
  305:     print($text);
  306:     print("\n");
  307:     print(&end());
  308:   }
  309: exit(0);
  310: 
  311: # ---------- Functions (most all just format contents of different markup tags)
  312: 
  313: # ------------------------ Final output at end of markup parsing and formatting
  314: sub end {
  315: 
  316: }
  317: 
  318: # ----------------------- Take in string to parse and the separation expression
  319: sub extract_array {
  320:     my ($stringtoparse,$sepexp) = @_;
  321:     my @a=split(/$sepexp/,$stringtoparse);
  322:     return \@a;
  323: }
  324: 
  325: # --------------------------------------------------------- Format piml section
  326: sub format_piml {
  327:     my (@tokeninfo)=@_;
  328:     my $date=`date`; chop $date;
  329:     $piml=<<END;
  330: #!/usr/bin/perl
  331: 
  332: # Generated from a PIML (Post Installation Markup Language) document
  333: 
  334: END
  335: }
  336: 
  337: # --------------------------------------------------- Format targetroot section
  338: sub format_targetroot {
  339:     my $text=&trim($parser->get_text('/targetroot'));
  340:     $text=$targetroot if $targetroot;
  341:     $parser->get_tag('/targetroot');
  342:     return('# TARGET INSTALL LOCATION is "'.$targetroot."\"\n");
  343: }
  344: 
  345: # -------------------------------------------------- Format perl script section
  346: sub format_perlscript {
  347:     my (@tokeninfo)=@_;
  348:     $mode=$tokeninfo[2]->{'mode'};
  349:     my $text=$parser->get_text('/perlscript');
  350:     $parser->get_tag('/perlscript');
  351:     if ($mode eq 'bg') {
  352: 	open(OUT,">/tmp/piml$$.pl");
  353: 	print(OUT $text);
  354: 	close(OUT);
  355: 	return(<<END);
  356: 	# launch background process for $target
  357: 	system("perl /tmp/piml$$.pl &");
  358: END
  359:     }
  360:     else {
  361: 	return($text);
  362:     }
  363: }
  364: 
  365: # --------------------------------------------------------------- Format TARGET
  366: sub format_TARGET {
  367:     my (@tokeninfo)=@_;
  368:     $parser->get_tag('/TARGET');
  369:     return($target);
  370: }
  371: 
  372: # ----------------------------------------------------------------- Format DIST
  373: sub format_DIST {
  374:     my (@tokeninfo)=@_;
  375:     $parser->get_tag('/DIST');
  376:     return($dist);
  377: }
  378: 
  379: # --------------------------------------------------- Format categories section
  380: sub format_categories {
  381:     my $text=&trim($parser->get_text('/categories'));
  382:     $parser->get_tag('/categories');
  383:     return('# CATEGORIES'."\n".$text);
  384: }
  385: 
  386: # --------------------------------------------------- Format categories section
  387: sub format_category {
  388:     my (@tokeninfo)=@_;
  389:     $category_att_name=$tokeninfo[2]->{'name'};
  390:     $category_att_type=$tokeninfo[2]->{'type'};
  391:     $abbreviation=''; $chmod='';$chown='';
  392:     $parser->get_text('/category');
  393:     $parser->get_tag('/category');
  394:     $fab{$category_att_name}=$abbreviation;
  395:     if ($category_att_type eq $categorytype) {
  396: 	my ($user,$group)=split(/\:/,$chown);
  397: 	$categoryhash{$category_att_name}='-o '.$user.' -g '.$group.
  398: 	    ' -m '.$chmod;
  399:     }
  400:     return('');
  401: }
  402: 
  403: # --------------------------------------------------- Format categories section
  404: sub format_abbreviation {
  405:     my @tokeninfo=@_;
  406:     $abbreviation='';
  407:     my $text=&trim($parser->get_text('/abbreviation'));
  408:     if ($text) {
  409: 	$parser->get_tag('/abbreviation');
  410: 	$abbreviation=$text;
  411:     }
  412:     return('');
  413: }
  414: 
  415: # -------------------------------------------------------- Format chown section
  416: sub format_chown {
  417:     my @tokeninfo=@_;
  418:     $chown='';
  419:     my $text=&trim($parser->get_text('/chown'));
  420:     if ($text) {
  421: 	$parser->get_tag('/chown');
  422: 	$chown=$text;
  423:     }
  424:     return('');
  425: }
  426: 
  427: # -------------------------------------------------------- Format chmod section
  428: sub format_chmod {
  429:     my @tokeninfo=@_;
  430:     $chmod='';
  431:     my $text=&trim($parser->get_text('/chmod'));
  432:     if ($text) {
  433: 	$parser->get_tag('/chmod');
  434: 	$chmod=$text;
  435:     }
  436:     return('');
  437: }
  438: 
  439: # ------------------------------------------------- Format categoryname section
  440: sub format_categoryname {
  441:     my @tokeninfo=@_;
  442:     $categoryname='';
  443:     my $text=&trim($parser->get_text('/categoryname'));
  444:     if ($text) {
  445: 	$parser->get_tag('/categoryname');
  446: 	$categoryname=$text;
  447:     }
  448:     return('');
  449: }
  450: 
  451: # -------------------------------------------------------- Format files section
  452: sub format_files {
  453:     my $text=$parser->get_text('/files');
  454:     $parser->get_tag('/files');
  455:     return("\n".'# There are '.$file_count.' files this script works on'.
  456: 	"\n\n".$text);
  457: }
  458: 
  459: # --------------------------------------------------------- Format file section
  460: sub format_file {
  461:     my @tokeninfo=@_;
  462:     $file=''; $source=''; $target=''; $categoryname=''; $description='';
  463:     $note=''; $build=''; $status=''; $dependencies='';
  464:     my $text=&trim($parser->get_text('/file'));
  465:     $file_count++;
  466:     $categorycount{$categoryname}++;
  467:     $parser->get_tag('/file');
  468:     return("# File: $target\n".
  469: 	"$text\n");
  470: }
  471: 
  472: # ------------------------------------------------------- Format target section
  473: sub format_target {
  474:     my @tokeninfo=@_;
  475:     $target='';
  476:     my $text=&trim($parser->get_text('/target'));
  477:     if ($text) {
  478: 	$parser->get_tag('/target');
  479: 	$target=$targetrootarg.$text;
  480:     }
  481:     return('');
  482: }
  483: 
  484: # --------------------------------------------------------- Format note section
  485: sub format_note {
  486:     my @tokeninfo=@_;
  487:     $note='';
  488:     my $aref;
  489:     my $text;
  490:     while ($aref=$parser->get_token()) {
  491: 	if ($aref->[0] eq 'E' && $aref->[1] eq 'note') {
  492: 	    last;
  493: 	}
  494: 	elsif ($aref->[0] eq 'S') {
  495: 	    $text.=$aref->[4];
  496: 	}
  497: 	elsif ($aref->[0] eq 'E') {
  498: 	    $text.=$aref->[2];
  499: 	}
  500: 	else {
  501: 	    $text.=$aref->[1];
  502: 	}
  503:     }
  504:     if ($text) {
  505: 	$note=$text;
  506:     }
  507:     return('');
  508: }
  509: 
  510: # ------------------------------------------------- Format dependencies section
  511: sub format_dependencies {
  512:     my @tokeninfo=@_;
  513:     $dependencies='';
  514:     my $text=&trim($parser->get_text('/dependencies'));
  515:     if ($text) {
  516: 	$parser->get_tag('/dependencies');
  517: 	$dependencies=join(';',
  518: 			      (map {s/^\s*//;s/\s$//;$_} split(/\;/,$text)));
  519:     }
  520:     return('');
  521: }
  522: 
  523: # ------------------------------------------------ Format specialnotice section
  524: sub format_specialnotices {
  525:     $parser->get_tag('/specialnotices');
  526:     return('');
  527: }
  528: 
  529: # ------------------------------------------------ Format specialnotice section
  530: sub format_specialnotice {
  531:     $parser->get_tag('/specialnotice');
  532:     return('');
  533: }
  534: 
  535: # ------------------------------------- Render less-than and greater-than signs
  536: sub htmlsafe {
  537:     my $text=@_[0];
  538:     $text =~ s/</&lt;/g;
  539:     $text =~ s/>/&gt;/g;
  540:     return($text);
  541: }
  542: 
  543: # --------------------------------------- remove starting and ending whitespace
  544: sub trim {
  545:     my ($s)=@_; $s=~s/^\s*//; $s=~s/\s*$//; return($s);
  546: }
  547: 
  548: # ----------------------------------- POD (plain old documentation, CPAN style)
  549: 
  550: =pod
  551: 
  552: =head1 NAME
  553: 
  554: piml_parse.pl - This is meant to parse files meeting the piml document type.
  555: See piml.dtd.  PIML=Post Installation Markup Language.
  556: 
  557: =head1 SYNOPSIS
  558: 
  559: Usage is for piml file to come in through standard input.
  560: 
  561: =over 4
  562: 
  563: =item * 
  564: 
  565: 1st argument is the category permissions to use (runtime or development)
  566: 
  567: =item *
  568: 
  569: 2nd argument is the distribution
  570: (default,redhat6,debian2.2,redhat7,etc).
  571: 
  572: =item *
  573: 
  574: 3rd argument is to manually specify a targetroot.
  575: 
  576: =back
  577: 
  578: Only the 1st argument is mandatory for the program to run.
  579: 
  580: Example:
  581: 
  582: cat ../../doc/loncapafiles.piml |\\
  583: perl piml_parse.pl development default /home/sherbert/loncapa
  584: 
  585: =head1 DESCRIPTION
  586: 
  587: I am using a multiple pass-through approach to parsing
  588: the piml file.  This saves memory and makes sure the server
  589: will never be overloaded.
  590: 
  591: =head1 README
  592: 
  593: I am using a multiple pass-through approach to parsing
  594: the piml file.  This saves memory and makes sure the server
  595: will never be overloaded.
  596: 
  597: =head1 PREREQUISITES
  598: 
  599: HTML::TokeParser
  600: 
  601: =head1 COREQUISITES
  602: 
  603: =head1 OSNAMES
  604: 
  605: linux
  606: 
  607: =head1 SCRIPT CATEGORIES
  608: 
  609: Packaging/Administrative
  610: 
  611: =head1 AUTHOR
  612: 
  613:  Scott Harrison
  614:  sharrison@users.sourceforge.net
  615: 
  616: Please let me know how/if you are finding this script useful and
  617: any/all suggestions.  -Scott
  618: 
  619: =cut