--- loncom/publisher/lonpublisher.pm 2001/08/18 16:38:37 1.42 +++ loncom/publisher/lonpublisher.pm 2002/08/09 19:49:30 1.92 @@ -1,5 +1,30 @@ # The LearningOnline Network with CAPA # Publication Handler +# +# $Id: lonpublisher.pm,v 1.92 2002/08/09 19:49:30 albertel Exp $ +# +# Copyright Michigan State University Board of Trustees +# +# This file is part of the LearningOnline Network with CAPA (LON-CAPA). +# +# LON-CAPA is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# LON-CAPA is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with LON-CAPA; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# /home/httpd/html/adm/gpl.txt +# +# http://www.lon-capa.org/ +# # # (TeX Content Handler # @@ -11,24 +36,86 @@ # 04/16/2001 Scott Harrison # 05/03,05/05,05/07 Gerd Kortemeyer # 05/28/2001 Scott Harrison -# 06/23,08/07,08/11,8/13,8/17 Gerd Kortemeyer +# 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 ## +## ## +############################################################################### + + +###################################################################### +###################################################################### + +=pod + +=head1 Name + +lonpublisher - LON-CAPA publishing handler + +=head1 Synopsis + +lonpublisher takes the proper steps to add resources to the LON-CAPA +digital library. This includes updating the metadata table in the +LON-CAPA database. + +=head1 Description + +lonpublisher is many things to many people. +To all people it is woefully documented. +This documentation conforms to this standard. + +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. + +=head2 Internal Functions + +=over 4 + +=cut + +###################################################################### +###################################################################### + 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(); +use Apache::lonmysql; my %addid; my %nokey; -my %language; -my %cprtag; my %metadatafields; my %metadatakeys; @@ -38,12 +125,23 @@ my $docroot; my $cuname; my $cudom; -# ----------------------------------------------- Evaluate string with metadata +######################################### +######################################### + +=pod +=item metaeval + +Evaluate string with metadata + +=cut + +######################################### +######################################### 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') { @@ -61,14 +159,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/) || @@ -82,8 +180,19 @@ sub metaeval { } } -# -------------------------------------------------------- Read a metadata file +######################################### +######################################### + +=pod + +=item metaread + +Read a metadata file + +=cut +######################################### +######################################### sub metaread { my ($logfile,$fn)=@_; unless (-e $fn) { @@ -100,16 +209,49 @@ sub metaread { return '
Processed file: '.$fn.''; } -# ---------------------------- convert 'time' format into a datetime sql format +######################################### +######################################### + +=pod + +=item sqltime + +Convert 'time' format into a datetime sql format + +=cut + +######################################### +######################################### 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"; } -# --------------------------------------------------------- Various form fields +######################################### +######################################### + +=pod + +=item Form field generating functions + +=over 4 + +=item textfield + +=item hiddenfield + +=item selectbox + +=back + +=cut + +######################################### +######################################### sub textfield { my ($title,$name,$value)=@_; return "\n

$title:
". @@ -122,30 +264,69 @@ sub hiddenfield { } sub selectbox { - my ($title,$name,$value,%options)=@_; - my $selout="\n

$title:
".''; + foreach (@idlist) { + $selout.='';} + } return $selout.''; } -# -------------------------------------------------------- Publication Step One +######################################### +######################################### + +=pod + +=item urlfixup +Fix up a url? First step of publication + +=cut + +######################################### +######################################### 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; +} + +######################################### +######################################### + +=pod + +=item absoluteurl + +Currently undocumented + +=cut + +######################################### +######################################### +sub absoluteurl { + my ($url,$target)=@_; + unless ($url) { return ''; } if ($target) { $target=~s/\/[^\/]+$//; $url=&Apache::lonnet::hreflocation($target,$url); @@ -153,6 +334,390 @@ sub urlfixup { return $url; } +######################################### +######################################### + +=pod + +=item set_allow + +Currently undocumented + +=cut + +######################################### +######################################### +sub set_allow { + my ($allow,$logfile,$target,$tag,$oldurl)=@_; + my $newurl=&urlfixup($oldurl,$target); + my $return_url=$oldurl; + print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; + if ($newurl ne $oldurl) { + $return_url=$newurl; + print $logfile 'URL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; + } + if (($newurl !~ /^javascript:/i) && + ($newurl !~ /^mailto:/i) && + ($newurl !~ /^http:/i) && + ($newurl !~ /^\#/)) { + $$allow{&absoluteurl($newurl,$target)}=1; + } + return $return_url +} + +######################################### +######################################### + +=pod + +=item get_subscribed_hosts + +Currently undocumented + +=cut + +######################################### +######################################### +sub get_subscribed_hosts { + my ($target)=@_; + my @subscribed; + my $filename; + $target=~/(.*)\/([^\/]+)$/; + my $srcf=$2; + opendir(DIR,$1); + while ($filename=readdir(DIR)) { + if ($filename=~/$srcf\.(\w+)$/) { + my $subhost=$1; + if ($subhost ne 'meta' && $subhost ne 'subscription') { + push(@subscribed,$subhost); + } + } + } + closedir(DIR); + my $sh; + if ( $sh=Apache::File->new("$target.subscription") ) { + &Apache::lonnet::logthis("opened $target.subscription"); + while (my $subline=<$sh>) { + &Apache::lonnet::logthis("Trying $subline"); + if ($subline =~ /(^\w+):/) { push(@subscribed,$1); } else { + &Apache::lonnet::logthis("No Match for $subline"); + } + } + } else { + &Apache::lonnet::logthis("Un able to open $target.subscription"); + } + &Apache::lonnet::logthis("Got list of ".join(':',@subscribed)); + return @subscribed; +} + + +######################################### +######################################### + +=pod + +=item get_max_ids_indices + +Currently undocumented + +=cut + +######################################### +######################################### +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); +} + +######################################### +######################################### + +=pod + +=item get_all_text_unbalanced + +Currently undocumented + +=cut + +######################################### +######################################### +sub get_all_text_unbalanced { + #there is a copy of this in lonxml.pm + my($tag,$pars)= @_; + my $token; + my $result=''; + $tag='<'.$tag.'>'; + while ($token = $$pars[-1]->get_token) { + if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) { + $result.=$token->[1]; + } elsif ($token->[0] eq 'PI') { + $result.=$token->[2]; + } elsif ($token->[0] eq 'S') { + $result.=$token->[4]; + } elsif ($token->[0] eq 'E') { + $result.=$token->[2]; + } + if ($result =~ /(.*)$tag(.*)/) { + #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2); + #&Apache::lonnet::logthis('Result is :'.$1); + $result=$1; + my $redo=$tag.$2; + push (@$pars,HTML::LCParser->new(\$redo)); + $$pars[-1]->xml_mode('1'); + last; + } + } + return $result +} + +######################################### +######################################### + +=pod + +=item fix_ids_and_indices + +Currently undocumented + +=cut + +######################################### +######################################### +#Arguably this should all be done as a 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)) { + if ($key =~ /^$type$/i) { + $parms{$key}=&set_allow(\%allow,$logfile, + $target,$tag, + $parms{$key}); + } + } + } + # probably a image type

Dependencies

'; + my $allowstr=''; + foreach (sort(keys(%allow))) { + my $thisdep=$_; + if ($thisdep !~ /[^\s]/) { next; } + unless ($style eq 'rat') { + $allowstr.="\n".''; + } + $scrout.='
'; + unless ($thisdep=~/\*/) { + $scrout.=''; + } + $scrout.=''.$thisdep.''; + unless ($thisdep=~/\*/) { + $scrout.=''; + if ( + &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. + $thisdep.'.meta') eq '-1') { + $scrout.= + ' - Currently not available'; + } else { + my %temphash=(&Apache::lonnet::declutter($target).'___'. + &Apache::lonnet::declutter($thisdep).'___usage' + => time); + $thisdep=~/^\/res\/(\w+)\/(\w+)\//; + if ((defined($1)) && (defined($2))) { + &Apache::lonnet::put('nohist_resevaldata',\%temphash, + $1,$2); + } + } + } } - { - my $parser=HTML::TokeParser->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::TokeParser->new(\$content); - my $token; - while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - my $counter; - my $tag=$token->[1]; - unless ($tag eq 'allow') { - my %parms=%{$token->[2]}; - if ($counter=$addid{$tag}) { - 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"; - } - } - } - - 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"; - } - $allow{$newurl}=1; - } - } ('src','href'); - - if ($tag 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'); - } - } + $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s; - my $newparmstring=''; - my $endtag=''; - map { - if ($_ eq '/') { - $endtag=' /'; - } else { - my $quote=($parms{$_}=~/\"/?"'":'"'); - $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; - } - } keys %parms; - - $outstring.='<'.$tag.$newparmstring.$endtag.'>'; - } else { - $allow{$token->[2]->{'src'}}=1; - } - } elsif ($token->[0] eq 'E') { - unless ($token->[1] eq 'allow') { - $outstring.='[1].'>'; - } - } else { - $outstring.=$token->[1]; - } - } -# ------------------------------------------------------------ Construct Allows - unless ($style eq 'rat') { - my $allowstr="\n"; - map { - $allowstr.=''."\n"; - } keys %allow; - $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s; - } + #Encode any High ASCII characters + $outstring=&HTML::Entities::encode($outstring,"\200-\377"); # ------------------------------------------------------------- Write modified { @@ -336,13 +800,6 @@ sub publish { } $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 @@ -352,6 +809,11 @@ sub publish { %metadatakeys=(); my %oldparmstores=(); + + + $scrout.='

Metadata Information ' . + Apache::loncommon::help_open_topic("Metadata_Description") + . '

'; # ------------------------------------------------ First, check out environment unless (-e $source.'.meta') { @@ -373,30 +835,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; + } } @@ -405,7 +867,7 @@ sub publish { my $oldenv=$ENV{'request.uri'}; $ENV{'request.uri'}=$target; - $allmeta=Apache::lonxml::xmlparse('meta',$content); + $allmeta=Apache::lonxml::xmlparse(undef,'meta',$content); $ENV{'request.uri'}=$oldenv; &metaeval($allmeta); @@ -413,7 +875,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{$_}) { @@ -422,14 +884,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+$/)) { @@ -437,7 +899,7 @@ sub publish { $chparms.=$_.' '; } } - } sort keys %oldparmstores; + } if ($chparms) { $scrout.='

Obsolete parameters or stored values: '. $chparms; @@ -446,20 +908,43 @@ sub publish { # ------------------------------------------------------- Now have all metadata $scrout.= - '

'. + ''. + '

'. &hiddenfield('phase','two'). &hiddenfield('filename',$ENV{'form.filename'}). &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)). + &hiddenfield('dependencies',join(',',keys %allow)). &textfield('Title','title',$metadatafields{'title'}). &textfield('Author(s)','author',$metadatafields{'author'}). &textfield('Subject','subject',$metadatafields{'subject'}); # --------------------------------------------------- Scan content for keywords - my $keywordout='

Keywords:
'; + my $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords"); + my $keywordout=<<"END"; + +

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

'; my $colcount=0; + my %keywords=(); - { + if (length($content)<500000) { my $textonly=$content; $textonly=~s/\//g; $textonly=~s/\[^\<]+\<\/m\>//g; @@ -468,34 +953,38 @@ 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; - $keywordout.='
'; if ($colcount>10) { $keywordout.="
'; - - } + } - $scrout.=$keywordout; + $keywordout.=''; + + $scrout.=$keywordout; $scrout.=&textfield('Additional Keywords','addkey',''); @@ -510,7 +999,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; @@ -522,22 +1014,49 @@ 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'}; + } + $scrout.=&selectbox('Copyright/Distribution','copyright', + $metadatafields{'copyright'}, + \&Apache::loncommon::copyrightdescription, + (grep !/^public$/,(&Apache::loncommon::copyrightids))); + } + else { $scrout.=&selectbox('Copyright/Distribution','copyright', - $metadatafields{'copyright'},%cprtag); + $metadatafields{'copyright'}, + \&Apache::loncommon::copyrightdescription, + (&Apache::loncommon::copyrightids)); + } + my $copyright_help = Apache::loncommon::help_open_topic("Publishing_Copyright"); + $scrout =~ s/DISTRIBUTION:/'DISTRIBUTION: ' . $copyright_help/ge; return $scrout. - '

'; + '

'; } -# -------------------------------------------------------- Publication Step Two +######################################### +######################################### + +=pod + +=item phasetwo + +Render second interface showing status of publication steps. +This is publication step two. +=cut + +######################################### +######################################### 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'; @@ -561,13 +1080,15 @@ sub phasetwo { $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'}; $metadatafields{'owner'}=$ENV{'form.owner'}; $metadatafields{'copyright'}=$ENV{'form.copyright'}; + $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; @@ -578,89 +1099,46 @@ 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; - my $dbh; - { - unless ( - $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) - ) { - $warning='WARNING: Cannot connect to '. - 'database!'; - } - else { - my %sqldatafields; - $sqldatafields{'url'}=$distarget; - my $sth=$dbh->prepare( - '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', - 'mime','language','creationdate','lastrevisiondate','owner', - 'copyright'); - - $sth=$dbh->prepare('insert into metadata values ('. - '"'.delete($sqldatafields{'title'}).'"'.','. - '"'.delete($sqldatafields{'author'}).'"'.','. - '"'.delete($sqldatafields{'subject'}).'"'.','. - '"'.delete($sqldatafields{'url'}).'"'.','. - '"'.delete($sqldatafields{'keywords'}).'"'.','. - '"'.'current'.'"'.','. - '"'.delete($sqldatafields{'notes'}).'"'.','. - '"'.delete($sqldatafields{'abstract'}).'"'.','. - '"'.delete($sqldatafields{'mime'}).'"'.','. - '"'.delete($sqldatafields{'language'}).'"'.','. - '"'. - sqltime(delete($sqldatafields{'creationdate'})) - .'"'.','. - '"'. - sqltime(delete( - $sqldatafields{'lastrevisiondate'})).'"'.','. - '"'.delete($sqldatafields{'owner'}).'"'.','. - '"'.delete( - $sqldatafields{'copyright'}).'"'.')'); - $sth->execute(); - $dbh->disconnect; - $scrout.='

Synchronized SQL metadata database'; - print $logfile "\nSynchronized SQL metadata database"; - } + $metadatafields{'url'} = $distarget; + $metadatafields{'version'} = 'current'; + unless ($metadatafields{'copyright'} eq 'priv') { + my ($error,$success) = &store_metadata(\%metadatafields); + if ($success) { + $scrout.='

Synchronized SQL metadata database'; + print $logfile "\nSynchronized SQL metadata database"; + } else { + $warning.=$error; + print $logfile "\n".$error; + } + } 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) { @@ -755,56 +1233,26 @@ if (-e $target) { # --------------------------------------------------- Send update notifications -{ - - my $filename; - - $target=~/(.*)\/([^\/]+)$/; - my $srcf=$2; - opendir(DIR,$1); - while ($filename=readdir(DIR)) { - if ($filename=~/$srcf\.(\w+)$/) { - my $subhost=$1; - if ($subhost ne 'meta') { - $scrout.='

Notifying host '.$subhost.':'; - print $logfile "\nNotifying host '.$subhost.':'"; - my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); - $scrout.=$reply; - print $logfile $reply; - } - } + my @subscribed=&get_subscribed_hosts($target); + foreach my $subhost (@subscribed) { + $scrout.='

Notifying host '.$subhost.':'; + print $logfile "\nNotifying host ".$subhost.':'; + my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); + $scrout.=$reply; + print $logfile $reply; } - closedir(DIR); - -} # ---------------------------------------- Send update notifications, meta only -{ - - my $filename; - - $target=~/(.*)\/([^\/]+)$/; - my $srcf=$2.'.meta'; - opendir(DIR,$1); - while ($filename=readdir(DIR)) { - if ($filename=~/$srcf\.(\w+)$/) { - my $subhost=$1; - if ($subhost ne 'meta') { - $scrout.= - '

Notifying host for metadata only '.$subhost.':'; - print $logfile - "\nNotifying host for metadata only '.$subhost.':'"; - my $reply=&Apache::lonnet::critical( - 'update:'.$target.'.meta',$subhost); - $scrout.=$reply; - print $logfile $reply; - } - } + my @subscribedmeta=&get_subscribed_hosts("$target.meta"); + foreach my $subhost (@subscribedmeta) { + $scrout.='

Notifying host for metadata only '.$subhost.':'; + print $logfile "\nNotifying host for metadata only ".$subhost.':'; + my $reply=&Apache::lonnet::critical('update:'.$target.'.meta', + $subhost); + $scrout.=$reply; + print $logfile $reply; } - closedir(DIR); - -} # ------------------------------------------------ Provide link to new resource @@ -819,15 +1267,43 @@ if (-e $target) { return $warning.$scrout. - '

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

Back to Source'. '

Back to Source Directory'; } -# ================================================================ Main Handler +######################################### +######################################### + +=pod + +=item handler + +A basic outline of the handler subroutine follows. + +=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 + +=cut + +######################################### +######################################### sub handler { my $r=shift; @@ -837,6 +1313,11 @@ sub handler { return OK; } +# Get query string for limited number of parameters + + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + ['filename']); + # -------------------------------------------------------------- Check filename my $fn=$ENV{'form.filename'}; @@ -868,7 +1349,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'); @@ -908,31 +1390,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>; + } } } @@ -951,7 +1413,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; @@ -965,7 +1427,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'})) { @@ -973,7 +1435,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

'); @@ -998,9 +1460,9 @@ unless ($ENV{'form.phase'} eq 'two') { 1; __END__ +=pod +=back - - - +=cut