--- loncom/publisher/lonpublisher.pm 2001/08/11 18:06:25 1.34 +++ loncom/publisher/lonpublisher.pm 2001/12/04 15:32:57 1.53 @@ -11,7 +11,7 @@ # 04/16/2001 Scott Harrison # 05/03,05/05,05/07 Gerd Kortemeyer # 05/28/2001 Scott Harrison -# 06/23,08/07,08/11 Gerd Kortemeyer +# 06/23,08/07,08/11,8/13,8/17,8/18,8/24,9/26,10/16 Gerd Kortemeyer package Apache::lonpublisher; @@ -71,7 +71,8 @@ sub metaeval { } @{$token->[3]}; if ($metadatafields{$unikey}) { my $newentry=$parser->get_text('/'.$entry); - unless ($metadatafields{$unikey}=~/$newentry/) { + unless (($metadatafields{$unikey}=~/$newentry/) || + ($newentry eq '')) { $metadatafields{$unikey}.=', '.$newentry; } } else { @@ -133,11 +134,23 @@ sub selectbox { # -------------------------------------------------------- Publication Step One -sub makeallowed { -} - sub urlfixup { - return shift; + my ($url,$target)=@_; + unless ($url) { return ''; } + my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/); + map { + if ($_ eq $host) { + $url=~s/^http\:\/\///; + $url=~s/^$host//; + } + } values %Apache::lonnet::hostname; + if ($url=~/^http\:\/\//) { return $url; } + $url=~s/\~$cuname/res\/$cudom\/$cuname/; + if ($target) { + $target=~s/\/[^\/]+$//; + $url=&Apache::lonnet::hreflocation($target,$url); + } + return $url; } sub publish { @@ -147,6 +160,8 @@ sub publish { my $scrout=''; my $allmeta=''; my $content=''; + my %allow=(); + undef %allow; unless ($logfile=Apache::File->new('>>'.$source.'.log')) { return @@ -210,14 +225,18 @@ sub publish { } my $outstring=''; my $parser=HTML::TokeParser->new(\$content); + $parser->xml_mode(1); my $token; while ($token=$parser->get_token) { if ($token->[0] eq 'S') { my $counter; my $tag=$token->[1]; - unless ($tag eq 'allow') { + my $lctag=$tag;$lctag=~/[A-Z]/[a-z]/g; + unless ($lctag eq 'allow') { my %parms=%{$token->[2]}; - if ($counter=$addid{$tag}) { + $counter=$addid{$tag}; + if (!$counter) { $counter=$addid{$lctag}; } + if ($counter) { if ($counter eq 'id') { unless (defined($parms{'id'})) { $maxid++; @@ -236,15 +255,46 @@ sub publish { map { if (defined($parms{$_})) { my $oldurl=$parms{$_}; - my $newurl=&urlfixup($oldurl); + my $newurl=&urlfixup($oldurl,$target); if ($newurl ne $oldurl) { $parms{$_}=$newurl; print $logfile 'URL: '.$tag.':'.$oldurl.' - '. $newurl."\n"; } - &makeallowed($newurl); + $allow{$newurl}=1; + } + } ('src','href','background'); + + 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{$codebase.'/*'}=1; + } else { + map { + if (defined($parms{$_})) { + my $oldurl=$parms{$_}; + my $newurl=&urlfixup($oldurl,$target); + $newurl=~s/\/[^\/]+$/\/\*/; + print $logfile 'Allow: applet '.$_.':'. + $oldurl.' allows '. + $newurl."\n"; + $allow{$newurl}=1; + } + } ('archive','code','object'); } - } ('src','href','codebase'); + } my $newparmstring=''; my $endtag=''; @@ -258,15 +308,36 @@ sub publish { } keys %parms; $outstring.='<'.$tag.$newparmstring.$endtag.'>'; - } + } else { + $allow{$token->[2]->{'src'}}=1; + } } elsif ($token->[0] eq 'E') { unless ($token->[1] eq 'allow') { - $outstring.=$token->[2]; + $outstring.='[1].'>'; } } else { $outstring.=$token->[1]; } } +# ------------------------------------------------------------ Construct Allows + unless ($style eq 'rat') { + $scrout.='

Dependencies

'; + my $allowstr="\n"; + map { + $allowstr.=''."\n"; + $scrout.='
'; + unless ($_=~/\*/) { + $scrout.=''; + } + $scrout.=''.$_.''; + unless ($_=~/\*/) { + $scrout.=''; + } + } keys %allow; + $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s; + } +# ------------------------------------------------------------- Write modified + { my $org; unless ($org=Apache::File->new('>'.$source)) { @@ -285,7 +356,7 @@ sub publish { } else { print $logfile "Does not need ID and/or index fixup\n"; } - + } # --------------------------------------------- Initial step done, now metadata # ---------------------------------------- Storage for metadata keys and fields @@ -294,6 +365,8 @@ sub publish { %metadatakeys=(); my %oldparmstores=(); + + $scrout.='

Metadata Information

'; # ------------------------------------------------ First, check out environment unless (-e $source.'.meta') { @@ -343,11 +416,15 @@ sub publish { } # -------------------------------------------------- Parse content for metadata + if ($style eq 'ssi') { + my $oldenv=$ENV{'request.uri'}; + $ENV{'request.uri'}=$target; $allmeta=Apache::lonxml::xmlparse('meta',$content); + $ENV{'request.uri'}=$oldenv; &metaeval($allmeta); - + } # ---------------- Find and document discrepancies in the parameters and stores my $chparms=''; @@ -380,7 +457,7 @@ sub publish { $scrout.='

Obsolete parameters or stored values: '. $chparms; } - } + # ------------------------------------------------------- Now have all metadata $scrout.= @@ -397,7 +474,7 @@ sub publish { my $keywordout='

Keywords:
'; my $colcount=0; - { + if (length($content)<500000) { my $textonly=$content; $textonly=~s/\//g; $textonly=~s/\[^\<]+\<\/m\>//g; @@ -429,11 +506,14 @@ sub publish { } $colcount++; } sort keys %keywords; - $keywordout.='
'; + } else { + $keywordout.='File too long for keyword analysis'; } - $scrout.=$keywordout; + $keywordout.=''; + + $scrout.=$keywordout; $scrout.=&textfield('Additional Keywords','addkey',''); @@ -460,6 +540,13 @@ sub publish { $scrout.=&textfield('Publisher/Owner','owner', $metadatafields{'owner'}); +# --------------------------------------------------- Correct copyright for rat + if ($style eq 'rat') { + if ($metadatafields{'copyright'} eq 'public') { + delete $metadatafields{'copyright'}; + } + delete $cprtag{'public'}; + } $scrout.=&selectbox('Copyright/Distribution','copyright', $metadatafields{'copyright'},%cprtag); @@ -775,6 +862,20 @@ sub handler { return OK; } +# Get query string for limited number of parameters + + map { + my ($name, $value) = split(/=/,$_); + $value =~ tr/+/ /; + $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + if ($name eq 'filename') { + unless ($ENV{'form.'.$name}) { + $ENV{'form.'.$name}=$value; + } + } + } (split(/&/,$ENV{'QUERY_STRING'})); + + # -------------------------------------------------------------- Check filename my $fn=$ENV{'form.filename'}; @@ -806,7 +907,8 @@ sub handler { return HTTP_NOT_ACCEPTABLE; } - $fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/; + $fn=~s/^http\:\/\/[^\/]+//; + $fn=~s/^\/\~(\w+)/\/home\/$1\/public_html/; my $targetdir=''; $docroot=$r->dir_config('lonDocRoot');