--- loncom/build/lpml_parse.pl 2002/03/22 01:55:04 1.41 +++ loncom/build/lpml_parse.pl 2005/12/09 20:41:35 1.53 @@ -1,11 +1,20 @@ #!/usr/bin/perl +# -------------------------------------------------------- Documentation notice +# Run "perldoc ./lpml_parse.pl" in order to best view the software +# documentation internalized in this program. + +# --------------------------------------------------------- Distribution notice +# This script is distributed with the LPML software project available at +# http://lpml.sourceforge.net + +# --------------------------------------------------------- License Information # The LearningOnline Network with CAPA # lpml_parse.pl - Linux Packaging Markup Language parser # -# $Id: lpml_parse.pl,v 1.41 2002/03/22 01:55:04 harris41 Exp $ +# $Id: lpml_parse.pl,v 1.53 2005/12/09 20:41:35 albertel Exp $ # -# Written by Scott Harrison, harris41@msu.edu +# Written by Scott Harrison, codeharrison@yahoo.com # # Copyright Michigan State University Board of Trustees # @@ -37,7 +46,9 @@ # 11/4,11/5,11/6,11/7,11/16,11/17 - Scott Harrison # 12/2,12/3,12/4,12/5,12/6,12/13,12/19,12/29 - Scott Harrison # YEAR=2002 -# 1/8,1/9,1/29,1/31,2/5,3/21 - Scott Harrison +# 1/8,1/9,1/29,1/31,2/5,3/21,4/8,4/12 - Scott Harrison +# 4/21,4/26,5/19,5/23,10/13 - Scott Harrison +# ### ############################################################################### @@ -67,9 +78,12 @@ use HTML::TokeParser; my $usage=<; -my $parsestring = join('',@parsecontents); -my $outstring; +# -------------------------- Start first pass through (just gather information) +my @parsecontents=<>; +my $parsestring=join('',@parsecontents); # Need to make a pass through and figure out what defaults are -# overrided. Top-down overriding strategy (leaves don't know -# about distant leaves). +# overrided. Top-down overriding strategy (tree leaves don't know +# about distant tree leaves). my @hierarchy; $hierarchy[0]=0; @@ -150,20 +165,32 @@ my $token; $parser = HTML::TokeParser->new(\$parsestring) or die('can\'t create TokeParser object'); $parser->xml_mode('1'); -my %hash; -my $key; -while ($token = $parser->get_token()) { +my %setting; + +# Values for the %setting hash +my $defaultset=1; # a default setting exists for a key +my $distset=2; # a distribution setting exists for a key + # (overrides default setting) + +my $key=''; # this is a unique key identifier (the token name with its + # coordinates inside the hierarchy) +while ($token = $parser->get_token()) { # navigate through $parsestring if ($token->[0] eq 'S') { $hloc++; $hierarchy[$hloc]++; $key=$token->[1].join(',',@hierarchy[0..($hloc-1)]); my $thisdist=' '.$token->[2]{'dist'}.' '; if ($thisdist eq ' default ') { - $hash{$key}=1; # there is a default setting for this key + $setting{$key}=$defaultset; } - elsif ($dist && $hash{$key}==1 && $thisdist=~/\s$dist\s/) { - $hash{$key}=2; # disregard default setting for this key if - # there is a directly requested distribution match + elsif (length($dist)>0 && + $setting{$key}==$defaultset && + $thisdist=~/\s$dist\s/) { + $setting{$key}=$distset; + # disregard default setting for this key if + # there is a directly requested distribution match + # (in other words, there must first be a default + # setting for a key in order for it to be overridden) } } if ($token->[0] eq 'E') { @@ -171,57 +198,79 @@ while ($token = $parser->get_token()) { } } -# --------------------------------------------------- Start second pass through -undef $hloc; -undef @hierarchy; -undef $parser; -$hierarchy[0]=0; +# - Start second pass through (clean up the string to allow for easy rendering) + +# The string is cleaned up so that there is no white-space surrounding any +# XML tag. White-space inside text 'T' elements is preserved. + +# Clear up memory +undef($hloc); +undef(@hierarchy); +undef($parser); +$hierarchy[0]=0; # initialize hierarchy $parser = HTML::TokeParser->new(\$parsestring) or die('can\'t create TokeParser object'); $parser->xml_mode('1'); -my $cleanstring; -while ($token = $parser->get_token()) { - if ($token->[0] eq 'S') { +my $cleanstring; # contains the output of the second step +while ($token = $parser->get_token()) { # navigate through $parsestring + if ($token->[0] eq 'S') { # a start tag $hloc++; $hierarchy[$hloc]++; $key=$token->[1].join(',',@hierarchy[0..($hloc-1)]); - my $thisdist=' '.$token->[2]{'dist'}.' '; + + # Surround tagdist (the dist attribute of an XML tag) + # with white-space to allow for uniform searching a few + # lines below here. + my $tagdist=' '.$token->[2]{'dist'}.' '; + # This conditional clause is set up to ignore two sets # of invalid conditions before accepting entry into - # the cleanstring. - if ($hash{$key}==2 and - !($thisdist eq ' ' or $thisdist =~/\s$dist\s/)) { + # $cleanstring. + + # Condition #1: Ignore this part of the string if the tag + # has a superior distribution-specific setting and the tag + # being evaluated has a dist setting something other than + # blank or $dist. + if ($setting{$key}==$distset and + !($tagdist eq ' ' or $tagdist =~/\s$dist\s/)) { if ($token->[4]!~/\/>$/) { $parser->get_tag('/'.$token->[1]); $hloc--; } } - elsif ($thisdist ne ' ' and $thisdist!~/\s$dist\s/ and - !($thisdist eq ' default ' and $hash{$key}!=2)) { + # Condition #2: Ignore this part of the string if the tag has + # is not blank and does not equal dist and + # either does not equal default or it has a prior $dist-specific + # setting. + elsif ($tagdist ne ' ' and $tagdist!~/\s$dist\s/ and + !($tagdist eq ' default ' and $setting{$key}!=$distset)) { if ($token->[4]!~/\/>$/) { $parser->get_tag('/'.$token->[1]); $hloc--; } } + # In other words, output to $cleanstring if the tag is dist=default + # or if the tag is set to dist=$dist for the first time. And, always + # output when dist='' is not present. else { $cleanstring.=$token->[4]; } - if ($token->[4]=~/\/>$/) { -# $hloc--; - } } - if ($token->[0] eq 'E') { + # Note: this loop DOES work with style markup as well as + # style markup since I always check for $token->[4] ending + # with "/>". + if ($token->[0] eq 'E') { # an end tag $cleanstring.=$token->[2]; $hloc--; } - if ($token->[0] eq 'T') { + if ($token->[0] eq 'T') { # text contents inside tags $cleanstring.=$token->[1]; } } $cleanstring=&trim($cleanstring); $cleanstring=~s/\>\s*\n\s*\\{textify}={ category => \&format_category, abbreviation => \&format_abbreviation, targetdir => \&format_targetdir, + protectionlevel => \&format_protectionlevel, chown => \&format_chown, chmod => \&format_chmod, rpm => \&format_rpm, @@ -333,8 +385,10 @@ $parser->{textify}={ target => \&format_target, note => \&format_note, build => \&format_build, + installscript => \&format_installscript, status => \&format_status, dependencies => \&format_dependencies, + privatedependencies => \&format_privatedependencies, buildlink => \&format_buildlink, glob => \&format_glob, sourcedir => \&format_sourcedir, @@ -591,6 +645,8 @@ sub format_category { my ($user,$group)=split(/\:/,$chown); $categoryhash{$category_att_name}='-o '.$user.' -g '.$group. ' -m '.$chmod; + $categoryhash{"chmod.".$category_att_name}=$chmod; + $categoryhash{"chown.".$category_att_name}=$chown; } return ''; } @@ -926,6 +982,9 @@ sub format_directories { elsif ($mode eq 'rpm_file_list') { return $text; } + elsif ($mode eq 'uninstall_shell_commands') { + return $text; + } else { return ''; } @@ -933,7 +992,7 @@ sub format_directories { # ---------------------------------------------------- Format directory section sub format_directory { my (@tokeninfo)=@_; - $targetdir='';$categoryname='';$description=''; + $targetdir='';$categoryname='';$description='';$protectionlevel=''; $parser->get_text('/directory'); $parser->get_tag('/directory'); $directory_count++; @@ -967,6 +1026,36 @@ sub format_directory { elsif ($mode eq 'rpm_file_list') { return $targetroot.'/'.$targetdir."\n"; } + elsif ($mode eq 'uninstall_shell_commands') { + if ($protectionlevel eq 'never_delete') { + return 'echo "LEAVING BEHIND '.$targetroot.'/'.$targetdir. + ' which may have important data worth saving"'."\n"; + } + elsif ($protectionlevel eq 'weak_delete') { + if ($targetdir!~/\w/) { + die("targetdir=\"$targetdir\"! NEVER EVER DELETE THE WHOLE ". + "FILESYSTEM"."\n"); + } + return 'rm -Rvf -i '.$targetroot.'/'.$targetdir."\n"; + } + elsif ($protectionlevel =~ /never/) { + die("CONFUSING PROTECTION LEVEL \"$protectionlevel\" FOUND ". + "FOR directory $targetdir"."\n"); + } + elsif ($protectionlevel !~ + /^never_delete|weak_delete|modest_delete|strong_delete|absolute_delete$/) { + die("CONFUSING OR MISSING PROTECTION LEVEL \"$protectionlevel\" ". + "FOUND FOR directory $targetdir\n"); + } + else { + if ($targetdir!~/\w/) { + die("targetdir=\"$targetdir\"! NEVER EVER DELETE THE WHOLE ". + "FILESYSTEM"."\n"); + } + return 'rm -Rvf '.$targetroot.'/'.$targetdir. + "| grep 'removed directory'"."\n"; + } + } else { return ''; } @@ -982,6 +1071,17 @@ sub format_targetdir { } return ''; } +# ---------------------------------------------- Format protectionlevel section +sub format_protectionlevel { + my @tokeninfo=@_; + $protectionlevel=''; + my $text=&trim($parser->get_text('/protectionlevel')); + if ($text) { + $parser->get_tag('/protectionlevel'); + $protectionlevel=$text; + } + return ''; +} # ------------------------------------------------- Format categoryname section sub format_categoryname { my @tokeninfo=@_; @@ -1008,7 +1108,10 @@ sub format_description { sub format_files { my $text=$parser->get_text('/files'); $parser->get_tag('/files'); - if ($mode eq 'html') { + if ($mode eq 'MANIFEST') { + return $text; + } + elsif ($mode eq 'html') { return $directories="\n
 
". "". "Files
 
". @@ -1119,14 +1222,31 @@ sub format_links { sub format_file { my @tokeninfo=@_; $file=''; $source=''; $target=''; $categoryname=''; $description=''; - $note=''; $build=''; $status=''; $dependencies=''; + $note=''; $build=''; $status=''; $dependencies=''; $installscript=''; my $text=&trim($parser->get_text('/file')); my $buildtest; $file_count++; $categorycount{$categoryname}++; if ($source) { $parser->get_tag('/file'); - if ($mode eq 'html') { + if ($mode eq 'MANIFEST') { + my $command=$build; + if ($command!~/\s/) { + $command=~s/\/([^\/]*)$//; + } + else { + $command=~s/(.*?\/)([^\/]+\s+.*)$/$1/; + } + $command=~s/^$sourceroot\///; + my (@deps)=split(/\;/,$dependencies); + my $retval=join("\n",($source, + (map {"$command$_"} @deps))); + if ($tokeninfo[2]{type} eq 'private') { + return "\n"; + } + return $retval."\n"; + } + elsif ($mode eq 'html') { return ($file="\n". "". "