--- loncom/publisher/lonpublisher.pm 2001/12/05 21:17:56 1.60 +++ loncom/publisher/lonpublisher.pm 2002/04/17 18:32:35 1.79 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Publication Handler # -# $Id: lonpublisher.pm,v 1.60 2001/12/05 21:17:56 www Exp $ +# $Id: lonpublisher.pm,v 1.79 2002/04/17 18:32:35 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -39,23 +39,45 @@ # 06/23,08/07,08/11,8/13,8/17,8/18,8/24,9/26,10/16 Gerd Kortemeyer # 12/04,12/05 Guy Albertelli # 12/05 Gerd Kortemeyer +# 12/05 Guy Albertelli +# 12/06,12/07 Gerd Kortemeyer +# 12/15,12/16 Scott Harrison +# 12/25 Gerd Kortemeyer +# YEAR=2002 +# 1/16,1/17 Scott Harrison +# 1/17 Gerd Kortemeyer +# +### + +############################################################################### +## ## +## ORGANIZATION OF THIS PERL MODULE ## +## ## +## 1. Modules used by this module ## +## 2. Various subroutines ## +## 3. Publication Step One ## +## 4. Phase Two ## +## 5. Main Handler ## +## ## +############################################################################### package Apache::lonpublisher; +# ------------------------------------------------- modules used by this module use strict; use Apache::File; use File::Copy; use Apache::Constants qw(:common :http :methods); -use HTML::TokeParser; +use HTML::LCParser; use Apache::lonxml; use Apache::lonhomework; use Apache::loncacc; use DBI; +use Apache::lonnet(); +use Apache::loncommon(); my %addid; my %nokey; -my %language; -my %cprtag; my %metadatafields; my %metadatakeys; @@ -66,11 +88,10 @@ my $cuname; my $cudom; # ----------------------------------------------- Evaluate string with metadata - sub metaeval { my $metastring=shift; - my $parser=HTML::TokeParser->new(\$metastring); + my $parser=HTML::LCParser->new(\$metastring); my $token; while ($token=$parser->get_token) { if ($token->[0] eq 'S') { @@ -88,14 +109,14 @@ sub metaeval { if (defined($token->[2]->{'name'})) { $unikey.='_'.$token->[2]->{'name'}; } - map { + foreach (@{$token->[3]}) { $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; if ($metadatakeys{$unikey}) { $metadatakeys{$unikey}.=','.$_; } else { $metadatakeys{$unikey}=$_; } - } @{$token->[3]}; + } if ($metadatafields{$unikey}) { my $newentry=$parser->get_text('/'.$entry); unless (($metadatafields{$unikey}=~/$newentry/) || @@ -110,7 +131,6 @@ sub metaeval { } # -------------------------------------------------------- Read a metadata file - sub metaread { my ($logfile,$fn)=@_; unless (-e $fn) { @@ -129,8 +149,9 @@ sub metaread { # ---------------------------- convert 'time' format into a datetime sql format sub sqltime { + my $timef=shift @_; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = - localtime(@_[0]); + localtime($timef); $mon++; $year+=1900; return "$year-$mon-$mday $hour:$min:$sec"; } @@ -149,13 +170,17 @@ sub hiddenfield { } sub selectbox { - my ($title,$name,$value,%options)=@_; - my $selout="\n

$title:
".''; + foreach (@idlist) { + $selout.='';} + } return $selout.''; } @@ -164,15 +189,27 @@ sub selectbox { sub urlfixup { my ($url,$target)=@_; unless ($url) { return ''; } + #javascript code needs no fixing + if ($url =~ /^javascript:/i) { return $url; } + if ($url =~ /^mailto:/i) { return $url; } + #internal document links need no fixing + if ($url =~ /^\#/) { return $url; } my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/); - map { + foreach (values %Apache::lonnet::hostname) { if ($_ eq $host) { $url=~s/^http\:\/\///; $url=~s/^$host//; } - } values %Apache::lonnet::hostname; + } if ($url=~/^http\:\/\//) { return $url; } $url=~s/\~$cuname/res\/$cudom\/$cuname/; + return $url; +} + + +sub absoluteurl { + my ($url,$target)=@_; + unless ($url) { return ''; } if ($target) { $target=~s/\/[^\/]+$//; $url=&Apache::lonnet::hreflocation($target,$url); @@ -220,7 +257,7 @@ sub publish { $content=join('',<$org>); } { - my $parser=HTML::TokeParser->new(\$content); + my $parser=HTML::LCParser->new(\$content); my $token; while ($token=$parser->get_token) { if ($token->[0] eq 'S') { @@ -251,7 +288,7 @@ sub publish { "Max Index: $maxindex (min 10)\n"; } my $outstring=''; - my $parser=HTML::TokeParser->new(\$content); + my $parser=HTML::LCParser->new(\$content); $parser->xml_mode(1); my $token; while ($token=$parser->get_token) { @@ -277,20 +314,28 @@ sub publish { print $logfile 'Index: '.$tag.':'.$maxindex."\n"; } } - } - - map { - if (defined($parms{$_})) { - my $oldurl=$parms{$_}; - my $newurl=&urlfixup($oldurl,$target); - if ($newurl ne $oldurl) { - $parms{$_}=$newurl; - print $logfile 'URL: '.$tag.':'.$oldurl.' - '. - $newurl."\n"; + } + + foreach my $type ('src','href','background','bgimg') { + foreach my $key (keys(%parms)) { + if ($key =~ /^$type$/i) { + my $oldurl=$parms{$key}; + my $newurl=&urlfixup($oldurl,$target); + if ($newurl ne $oldurl) { + $parms{$key}=$newurl; + print $logfile 'URL: '.$tag.':'.$oldurl.' - '. + $newurl."\n"; + } + if (($newurl !~ /^javascript:/i) && + ($newurl !~ /^mailto:/i) && + ($newurl !~ /^http:/i) && + ($newurl !~ /^\#/)) { + $allow{&absoluteurl($newurl,$target)}=1; + } } - $allow{$newurl}=1; - } - } ('src','href','background'); + last; + } + } if ($lctag eq 'applet') { my $codebase=''; @@ -307,9 +352,9 @@ sub publish { $oldcodebase.' - '. $codebase."\n"; } - $allow{$codebase.'/*'}=1; + $allow{&absoluteurl($codebase,$target).'/*'}=1; } else { - map { + foreach ('archive','code','object') { if (defined($parms{$_})) { my $oldurl=$parms{$_}; my $newurl=&urlfixup($oldurl,$target); @@ -317,22 +362,22 @@ sub publish { print $logfile 'Allow: applet '.$_.':'. $oldurl.' allows '. $newurl."\n"; - $allow{$newurl}=1; + $allow{&absoluteurl($newurl,$target)}=1; } - } ('archive','code','object'); + } } } my $newparmstring=''; my $endtag=''; - map { + foreach (keys %parms) { if ($_ eq '/') { $endtag=' /'; } else { my $quote=($parms{$_}=~/\"/?"'":'"'); $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; } - } keys %parms; + } if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } $outstring.='<'.$tag.$newparmstring.$endtag.'>'; } else { @@ -349,12 +394,15 @@ sub publish { } } # ------------------------------------------------------------ Construct Allows - unless ($style eq 'rat') { + $scrout.='

Dependencies

'; - my $allowstr="\n"; - map { + my $allowstr=''; + foreach (sort(keys(%allow))) { my $thisdep=$_; - $allowstr.=''."\n"; + if ($thisdep !~ /[^\s]/) { next; } + unless ($style eq 'rat') { + $allowstr.="\n".''; + } $scrout.='
'; unless ($thisdep=~/\*/) { $scrout.=''; @@ -377,9 +425,12 @@ sub publish { } } } - } keys %allow; + } + $allowstr=~s/\n+/\n/g; $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s; - } + + #Encode any High ASCII characters + $outstring=&HTML::Entities::encode($outstring,"\200-\377"); # ------------------------------------------------------------- Write modified { @@ -432,30 +483,30 @@ sub publish { my $currentpath='/home/'.$cuname.'/'; - map { + foreach (@urlparts) { $currentpath.=$_.'/'; $scrout.=&metaread($logfile,$currentpath.'default.meta'); - } @urlparts; + } # ------------------- Clear out parameters and stores (there should not be any) - map { + foreach (keys %metadatafields) { if (($_=~/^parameter/) || ($_=~/^stores/)) { delete $metadatafields{$_}; } - } keys %metadatafields; + } } else { # ---------------------- Read previous metafile, remember parameters and stores $scrout.=&metaread($logfile,$source.'.meta'); - map { + foreach (keys %metadatafields) { if (($_=~/^parameter/) || ($_=~/^stores/)) { $oldparmstores{$_}=1; delete $metadatafields{$_}; } - } keys %metadatafields; + } } @@ -472,7 +523,7 @@ sub publish { # ---------------- Find and document discrepancies in the parameters and stores my $chparms=''; - map { + foreach (sort keys %metadatafields) { if (($_=~/^parameter/) || ($_=~/^stores/)) { unless ($_=~/\.\w+$/) { unless ($oldparmstores{$_}) { @@ -481,14 +532,14 @@ sub publish { } } } - } sort keys %metadatafields; + } if ($chparms) { $scrout.='

New parameters or stored values: '. $chparms; } - my $chparms=''; - map { + $chparms=''; + foreach (sort keys %oldparmstores) { if (($_=~/^parameter/) || ($_=~/^stores/)) { unless (($metadatafields{$_.'.name'}) || ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { @@ -496,7 +547,7 @@ sub publish { $chparms.=$_.' '; } } - } sort keys %oldparmstores; + } if ($chparms) { $scrout.='

Obsolete parameters or stored values: '. $chparms; @@ -505,7 +556,8 @@ sub publish { # ------------------------------------------------------- Now have all metadata $scrout.= - '

'. + ''. + '

'. &hiddenfield('phase','two'). &hiddenfield('filename',$ENV{'form.filename'}). &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)). @@ -516,8 +568,28 @@ sub publish { # --------------------------------------------------- Scan content for keywords - my $keywordout='

Keywords:
'; + my $keywordout=<<"END"; + +

Keywords: + + +
+END + $keywordout.='

'; my $colcount=0; + my %keywords=(); if (length($content)<500000) { my $textonly=$content; @@ -528,33 +600,34 @@ sub publish { $textonly=~s/[\$\&][a-z]\w*//g; $textonly=~s/[^a-z\s]//g; - my %keywords=(); - map { + foreach ($textonly=~m/(\w+)/g) { unless ($nokey{$_}) { $keywords{$_}=1; } - } ($textonly=~m/(\w+)/g); + } + } - map { + + foreach (split(/\W+/,$metadatafields{'keywords'})) { $keywords{$_}=1; - } split(/\W+/,$metadatafields{'keywords'}); + } - map { - $keywordout.='\n"; $colcount=0; } $colcount++; - } sort keys %keywords; - - } else { - $keywordout.=''; - } + } $keywordout.='
'; if ($colcount>10) { $keywordout.="
File too long for keyword analysis
'; @@ -573,7 +646,10 @@ sub publish { $scrout.=&hiddenfield('mime',$1); $scrout.=&selectbox('Language','language', - $metadatafields{'language'},%language); + $metadatafields{'language'}, + \&Apache::loncommon::languagedescription, + (&Apache::loncommon::languageids), + ); unless ($metadatafields{'creationdate'}) { $metadatafields{'creationdate'}=time; @@ -587,17 +663,22 @@ sub publish { $metadatafields{'owner'}); # --------------------------------------------------- Correct copyright for rat if ($style eq 'rat') { - if ($metadatafields{'copyright'} eq 'public') { - delete $metadatafields{'copyright'}; - } - delete $cprtag{'public'}; - } - + if ($metadatafields{'copyright'} eq 'public') { + delete $metadatafields{'copyright'}; + } $scrout.=&selectbox('Copyright/Distribution','copyright', - $metadatafields{'copyright'},%cprtag); - + $metadatafields{'copyright'}, + \&Apache::loncommon::copyrightdescription, + (grep !/^public$/,(&Apache::loncommon::copyrightids))); + } + else { + $scrout.=&selectbox('Copyright/Distribution','copyright', + $metadatafields{'copyright'}, + \&Apache::loncommon::copyrightdescription, + (&Apache::loncommon::copyrightids)); + } return $scrout. - '

'; + '

'; } # -------------------------------------------------------- Publication Step Two @@ -607,7 +688,6 @@ sub phasetwo { my ($source,$target,$style,$distarget)=@_; my $logfile; my $scrout=''; - unless ($logfile=Apache::File->new('>>'.$source.'.log')) { return 'No write permission to user directory, FAIL'; @@ -634,11 +714,12 @@ sub phasetwo { $metadatafields{'dependencies'}=$ENV{'form.dependencies'}; my $allkeywords=$ENV{'form.addkey'}; - map { - if ($_=~/^form\.key\.(\w+)/) { - $allkeywords.=','.$1; + if (exists($ENV{'form.keywords'}) && (ref($ENV{'form.keywords'}))) { + my @Keywords = @{$ENV{'form.keywords'}}; + foreach (@Keywords) { + $allkeywords.=','.$_; } - } keys %ENV; + } $allkeywords=~s/\W+/\,/; $allkeywords=~s/^\,//; $metadatafields{'keywords'}=$allkeywords; @@ -649,44 +730,38 @@ sub phasetwo { unless ($mfh=Apache::File->new('>'.$source.'.meta')) { return 'Could not write metadata, FAIL'; - } - map { + } + foreach (sort keys %metadatafields) { unless ($_=~/\./) { my $unikey=$_; $unikey=~/^([A-Za-z]+)/; my $tag=$1; $tag=~tr/A-Z/a-z/; print $mfh "\n\<$tag"; - map { + foreach (split(/\,/,$metadatakeys{$unikey})) { my $value=$metadatafields{$unikey.'.'.$_}; $value=~s/\"/\'\'/g; print $mfh ' '.$_.'="'.$value.'"'; - } split(/\,/,$metadatakeys{$unikey}); - print $mfh '>'.$metadatafields{$unikey}.''; + } + print $mfh '>'. + &HTML::Entities::encode($metadatafields{$unikey}) + .''; } - } sort keys %metadatafields; + } $scrout.='

Wrote Metadata'; print $logfile "\nWrote metadata"; } # -------------------------------- Synchronize entry with SQL metadata database - my %perlvar; - open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; - my $configline; - while ($configline=) { - if ($configline =~ /PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } - } - close(CONFIG); + my $warning; + + unless ($metadatafields{'copyright'} eq 'priv') { - my $warning; my $dbh; { unless ( - $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) + $dbh = DBI->connect("DBI:mysql:loncapa","www", + $Apache::lonnet::perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) ) { $warning='WARNING: Cannot connect to '. 'database!'; @@ -698,11 +773,12 @@ sub phasetwo { 'delete from metadata where url like binary'. '"'.$sqldatafields{'url'}.'"'); $sth->execute(); - map {my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g; - $sqldatafields{$_}=$field;} - ('title','author','subject','keywords','notes','abstract', + foreach ('title','author','subject','keywords','notes','abstract', 'mime','language','creationdate','lastrevisiondate','owner', - 'copyright'); + 'copyright') { + my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g; + $sqldatafields{$_}=$field; + } $sth=$dbh->prepare('insert into metadata values ('. '"'.delete($sqldatafields{'title'}).'"'.','. @@ -731,7 +807,11 @@ sub phasetwo { } } - +} else { + $scrout.='

Private Publication - did not synchronize database'; + print $logfile "\nPrivate: Did not synchronize data into ". + "SQL metadata database"; +} # ----------------------------------------------------------- Copy old versions if (-e $target) { @@ -890,7 +970,7 @@ if (-e $target) { return $warning.$scrout. - '

View Target'. + '
View Published Version'. '

Back to Source'. '

Back to Source Directory'; @@ -910,7 +990,7 @@ sub handler { # Get query string for limited number of parameters - map { + foreach (split(/&/,$ENV{'QUERY_STRING'})) { my ($name, $value) = split(/=/,$_); $value =~ tr/+/ /; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; @@ -919,7 +999,7 @@ sub handler { $ENV{'form.'.$name}=$value; } } - } (split(/&/,$ENV{'QUERY_STRING'})); + } # -------------------------------------------------------------- Check filename @@ -994,31 +1074,11 @@ unless ($ENV{'form.phase'} eq 'two') { { my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); - map { + while (<$fh>) { my $word=$_; chomp($word); $nokey{$word}=1; - } <$fh>; - } - - %language=(); - - { - my $fh=Apache::File->new($r->dir_config('lonTabDir').'/language.tab'); - map { - $_=~/(\w+)\s+([\w\s\-]+)/; - $language{$1}=$2; - } <$fh>; - } - - %cprtag=(); - - { - my $fh=Apache::File->new($r->dir_config('lonIncludes').'/copyright.tab'); - map { - $_=~/(\w+)\s+([\w\s\-]+)/; - $cprtag{$1}=$2; - } <$fh>; + } } } @@ -1037,7 +1097,7 @@ unless ($ENV{'form.phase'} eq 'two') { { $thisfn=~/\.(\w+)$/; my $thistype=$1; - my $thisembstyle=&Apache::lonnet::fileembstyle($thistype); + my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); my $thistarget=$thisfn; @@ -1051,7 +1111,7 @@ unless ($ENV{'form.phase'} eq 'two') { $thisdisfn=~s/^\/home\/$cuname\/public_html\///; $r->print('

Publishing '. - &Apache::lonnet::filedescription($thistype).' '. + &Apache::loncommon::filedescription($thistype).' '. $thisdisfn.'

Target: '.$thisdistarget.'

'); if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) { @@ -1059,7 +1119,7 @@ unless ($ENV{'form.phase'} eq 'two') { ''); } - if (&Apache::lonnet::fileembstyle($thistype) eq 'ssi') { + if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { $r->print('
Diffs with Current Version

'); @@ -1084,9 +1144,107 @@ unless ($ENV{'form.phase'} eq 'two') { 1; __END__ +=head1 NAME + +Apache::lonpublisher - Publication Handler + +=head1 SYNOPSIS + +Invoked by /etc/httpd/conf/srm.conf: + + + PerlAccessHandler Apache::lonacc + SetHandler perl-script + PerlHandler Apache::lonpublisher + ErrorDocument 403 /adm/login + ErrorDocument 404 /adm/notfound.html + ErrorDocument 406 /adm/unauthorized.html + ErrorDocument 500 /adm/errorhandler + + +=head1 INTRODUCTION + +This module publishes a file. This involves gathering metadata, +versioning the file, copying file from construction space to +publication space, and copying metadata from construction space +to publication space. + +This is part of the LearningOnline Network with CAPA project +described at http://www.lon-capa.org. + +=head1 HANDLER SUBROUTINE + +This routine is called by Apache and mod_perl. + +=over 4 + +=item * + +Get query string for limited number of parameters + +=item * + +Check filename + +=item * + +File is there and owned, init lookup tables + +=item * + +Start page output + +=item * + +Individual file + +=item * + +publish from $thisfn to $thistarget with $thisembstyle + +=back + +=head1 OTHER SUBROUTINES + +=over 4 + +=item * + +metaeval() : Evaluate string with metadata + +=item * + +metaread() : Read a metadata file + +=item * + +sqltime() : convert 'time' format into a datetime sql format + +=item * + +textfield() : form field + +=item * + +hiddenfield() : form field + +=item * + +selectbox() : form field + +=item * + +urlfixup() : fixup URL (Publication Step One) +=item * +publish() : publish (Publication Step One) +=item * +phasetwo() : render second interface showing status of publication steps +(Publication Step Two) +=back +=cut 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.