[LON-CAPA-cvs] cvs: loncom /publisher lonpublisher.pm
albertel
lon-capa-cvs@mail.lon-capa.org
Wed, 07 Aug 2002 19:45:06 -0000
This is a MIME encoded message
--albertel1028749506
Content-Type: text/plain
albertel Wed Aug 7 15:45:06 2002 EDT
Modified files:
/loncom/publisher lonpublisher.pm
Log:
- refactorized some of the publish subroutine (only 310 lines long now)
--albertel1028749506
Content-Type: text/plain
Content-Disposition: attachment; filename="albertel-20020807154506.txt"
Index: loncom/publisher/lonpublisher.pm
diff -u loncom/publisher/lonpublisher.pm:1.85 loncom/publisher/lonpublisher.pm:1.86
--- loncom/publisher/lonpublisher.pm:1.85 Fri Jul 26 15:35:20 2002
+++ loncom/publisher/lonpublisher.pm Wed Aug 7 15:45:05 2002
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Publication Handler
#
-# $Id: lonpublisher.pm,v 1.85 2002/07/26 19:35:20 albertel Exp $
+# $Id: lonpublisher.pm,v 1.86 2002/08/07 19:45:05 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -267,6 +267,176 @@
return @subscribed;
}
+
+sub get_max_ids_indices {
+ my ($content)=@_;
+ my $maxindex=10;
+ my $maxid=10;
+ my $needsfixup=0;
+
+ my $parser=HTML::LCParser->new($content);
+ my $token;
+ while ($token=$parser->get_token) {
+ if ($token->[0] eq 'S') {
+ my $counter;
+ if ($counter=$addid{$token->[1]}) {
+ if ($counter eq 'id') {
+ if (defined($token->[2]->{'id'})) {
+ $maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
+ } else {
+ $needsfixup=1;
+ }
+ } else {
+ if (defined($token->[2]->{'index'})) {
+ $maxindex=($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
+ } else {
+ $needsfixup=1;
+ }
+ }
+ }
+ }
+ }
+ return ($needsfixup,$maxid,$maxindex);
+}
+
+#Arguably this should all be done as an lonnet::ssi instead
+sub fix_ids_and_indices {
+ my ($logfile,$source,$target)=@_;
+
+ my %allow;
+ my $content;
+ {
+ my $org=Apache::File->new($source);
+ $content=join('',<$org>);
+ }
+
+ my ($needsfixup,$maxid,$maxindex)=&get_max_ids_indices(\$content);
+
+ if ($needsfixup) {
+ print $logfile "Needs ID and/or index fixup\n".
+ "Max ID : $maxid (min 10)\n".
+ "Max Index: $maxindex (min 10)\n";
+ }
+ my $outstring='';
+ my @parser;
+ $parser[0]=HTML::LCParser->new(\$content);
+ $parser[-1]->xml_mode(1);
+ my $token;
+ while (@parser) {
+ while ($token=$parser[-1]->get_token) {
+ if ($token->[0] eq 'S') {
+ my $counter;
+ my $tag=$token->[1];
+ my $lctag=lc($tag);
+ if ($lctag eq 'allow') {
+ $allow{$token->[2]->{'src'}}=1;
+ next;
+ }
+ my %parms=%{$token->[2]};
+ $counter=$addid{$tag};
+ if (!$counter) { $counter=$addid{$lctag}; }
+ if ($counter) {
+ if ($counter eq 'id') {
+ unless (defined($parms{'id'})) {
+ $maxid++;
+ $parms{'id'}=$maxid;
+ print $logfile 'ID: '.$tag.':'.$maxid."\n";
+ }
+ } elsif ($counter eq 'index') {
+ unless (defined($parms{'index'})) {
+ $maxindex++;
+ $parms{'index'}=$maxindex;
+ print $logfile 'Index: '.$tag.':'.$maxindex."\n";
+ }
+ }
+ }
+ foreach my $type ('src','href','background','bgimg') {
+ foreach my $key (keys(%parms)) {
+ print $logfile "for $type, and $key\n";
+ if ($key =~ /^$type$/i) {
+ print $logfile "calling set_allow\n";
+ $parms{$key}=&set_allow(\%allow,$logfile,
+ $target,$tag,
+ $parms{$key});
+ }
+ }
+ }
+ # probably a <randomlabel> image type <label>
+ if ($lctag eq 'label' && defined($parms{'description'})) {
+ my $next_token=$parser[-1]->get_token();
+ if ($next_token->[0] eq 'T') {
+ $next_token->[1]=&set_allow(\%allow,$logfile,
+ $target,$tag,
+ $next_token->[1]);
+ }
+ $parser[-1]->unget_token($next_token);
+ }
+ if ($lctag eq 'applet') {
+ my $codebase='';
+ if (defined($parms{'codebase'})) {
+ my $oldcodebase=$parms{'codebase'};
+ unless ($oldcodebase=~/\/$/) {
+ $oldcodebase.='/';
+ }
+ $codebase=&urlfixup($oldcodebase,$target);
+ $codebase=~s/\/$//;
+ if ($codebase ne $oldcodebase) {
+ $parms{'codebase'}=$codebase;
+ print $logfile 'URL codebase: '.$tag.':'.
+ $oldcodebase.' - '.
+ $codebase."\n";
+ }
+ $allow{&absoluteurl($codebase,$target).'/*'}=1;
+ } else {
+ foreach ('archive','code','object') {
+ if (defined($parms{$_})) {
+ my $oldurl=$parms{$_};
+ my $newurl=&urlfixup($oldurl,$target);
+ $newurl=~s/\/[^\/]+$/\/\*/;
+ print $logfile 'Allow: applet '.$_.':'.
+ $oldurl.' allows '.
+ $newurl."\n";
+ $allow{&absoluteurl($newurl,$target)}=1;
+ }
+ }
+ }
+ }
+ my $newparmstring='';
+ my $endtag='';
+ foreach (keys %parms) {
+ if ($_ eq '/') {
+ $endtag=' /';
+ } else {
+ my $quote=($parms{$_}=~/\"/?"'":'"');
+ $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
+ }
+ }
+ if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
+ $outstring.='<'.$tag.$newparmstring.$endtag.'>';
+ } elsif ($token->[0] eq 'E') {
+ if ($token->[2]) {
+ unless ($token->[1] eq 'allow') {
+ $outstring.='</'.$token->[1].'>';
+ }
+ }
+ } else {
+ $outstring.=$token->[1];
+ }
+ }
+ pop(@parser);
+ }
+
+ if ($needsfixup) {
+ print $logfile "End of ID and/or index fixup\n".
+ "Max ID : $maxid (min 10)\n".
+ "Max Index: $maxindex (min 10)\n";
+ } else {
+ print $logfile "Does not need ID and/or index fixup\n";
+ }
+
+ return ($outstring,%allow);
+}
+
sub publish {
my ($source,$target,$style)=@_;
@@ -275,7 +445,6 @@
my $allmeta='';
my $content='';
my %allow=();
- undef %allow;
unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
return
@@ -296,153 +465,9 @@
return "<font color=red>Failed to write backup copy, $!,FAIL</font>";
}
# ------------------------------------------------------------- IDs and indices
-
- my $maxindex=10;
- my $maxid=10;
-
- my $needsfixup=0;
-
- {
- my $org=Apache::File->new($source);
- $content=join('',<$org>);
- }
- {
- my $parser=HTML::LCParser->new(\$content);
- my $token;
- while ($token=$parser->get_token) {
- if ($token->[0] eq 'S') {
- my $counter;
- if ($counter=$addid{$token->[1]}) {
- if ($counter eq 'id') {
- if (defined($token->[2]->{'id'})) {
- $maxid=
- ($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
- } else {
- $needsfixup=1;
- }
- } else {
- if (defined($token->[2]->{'index'})) {
- $maxindex=
- ($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
- } else {
- $needsfixup=1;
- }
- }
- }
- }
- }
- }
- if ($needsfixup) {
- print $logfile "Needs ID and/or index fixup\n".
- "Max ID : $maxid (min 10)\n".
- "Max Index: $maxindex (min 10)\n";
- }
- my $outstring='';
- my $parser=HTML::LCParser->new(\$content);
- $parser->xml_mode(1);
- my $token;
- while ($token=$parser->get_token) {
- if ($token->[0] eq 'S') {
- my $counter;
- my $tag=$token->[1];
- my $lctag=lc($tag);
- unless ($lctag eq 'allow') {
- my %parms=%{$token->[2]};
- $counter=$addid{$tag};
- if (!$counter) { $counter=$addid{$lctag}; }
- if ($counter) {
- if ($counter eq 'id') {
- unless (defined($parms{'id'})) {
- $maxid++;
- $parms{'id'}=$maxid;
- print $logfile 'ID: '.$tag.':'.$maxid."\n";
- }
- } elsif ($counter eq 'index') {
- unless (defined($parms{'index'})) {
- $maxindex++;
- $parms{'index'}=$maxindex;
- print $logfile 'Index: '.$tag.':'.$maxindex."\n";
- }
- }
- }
-
- foreach my $type ('src','href','background','bgimg') {
- foreach my $key (keys(%parms)) {
- print $logfile "for $type, and $key\n";
- if ($key =~ /^$type$/i) {
- print $logfile "calling set_allow\n";
- $parms{$key}=&set_allow(\%allow,$logfile,
- $target,$tag,
- $parms{$key});
- }
- }
- }
- # probably a <randomlabel> image type <label>
- if ($lctag eq 'label' && defined($parms{'description'})) {
- my $next_token=$parser->get_token();
- if ($next_token->[0] eq 'T') {
- $next_token->[1]=&set_allow(\%allow,$logfile,
- $target,$tag,
- $next_token->[1]);
- }
- $parser->unget_token($next_token);
- }
- if ($lctag eq 'applet') {
- my $codebase='';
- if (defined($parms{'codebase'})) {
- my $oldcodebase=$parms{'codebase'};
- unless ($oldcodebase=~/\/$/) {
- $oldcodebase.='/';
- }
- $codebase=&urlfixup($oldcodebase,$target);
- $codebase=~s/\/$//;
- if ($codebase ne $oldcodebase) {
- $parms{'codebase'}=$codebase;
- print $logfile 'URL codebase: '.$tag.':'.
- $oldcodebase.' - '.
- $codebase."\n";
- }
- $allow{&absoluteurl($codebase,$target).'/*'}=1;
- } else {
- foreach ('archive','code','object') {
- if (defined($parms{$_})) {
- my $oldurl=$parms{$_};
- my $newurl=&urlfixup($oldurl,$target);
- $newurl=~s/\/[^\/]+$/\/\*/;
- print $logfile 'Allow: applet '.$_.':'.
- $oldurl.' allows '.
- $newurl."\n";
- $allow{&absoluteurl($newurl,$target)}=1;
- }
- }
- }
- }
-
- my $newparmstring='';
- my $endtag='';
- foreach (keys %parms) {
- if ($_ eq '/') {
- $endtag=' /';
- } else {
- my $quote=($parms{$_}=~/\"/?"'":'"');
- $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
- }
- }
- if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
- $outstring.='<'.$tag.$newparmstring.$endtag.'>';
- } else {
- $allow{$token->[2]->{'src'}}=1;
- }
- } elsif ($token->[0] eq 'E') {
- if ($token->[2]) {
- unless ($token->[1] eq 'allow') {
- $outstring.='</'.$token->[1].'>';
- }
- }
- } else {
- $outstring.=$token->[1];
- }
- }
+
+ my $outstring;
+ ($outstring,%allow)=&fix_ids_and_indices($logfile,$source,$target);
# ------------------------------------------------------------ Construct Allows
$scrout.='<h3>Dependencies</h3>';
@@ -493,13 +518,6 @@
}
$content=$outstring;
- if ($needsfixup) {
- print $logfile "End of ID and/or index fixup\n".
- "Max ID : $maxid (min 10)\n".
- "Max Index: $maxindex (min 10)\n";
- } else {
- print $logfile "Does not need ID and/or index fixup\n";
- }
}
# --------------------------------------------- Initial step done, now metadata
--albertel1028749506--