loncom/publisher/lonpublisher.pm - view

File: [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.92: download - view: text, annotated - select for diffs
Fri Aug 9 19:49:30 2002 UTC (21 years, 10 months ago) by albertel
Branches: MAIN
CVS tags: HEAD

- fixes bug#257, moved resevaldata.db to nohist_resevaldata.db, and deletes hist file

- After installing these diffs you need to do a make install before restarting the webserver

# 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 # # 05/29/00,05/30,10/11 Gerd Kortemeyer) # # 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer # 03/23 Guy Albertelli # 03/24,03/29,04/03 Gerd Kortemeyer # 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,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::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 %metadatafields; my %metadatakeys; my $docroot; my $cuname; my $cudom; ######################################### ######################################### =pod =item metaeval Evaluate string with metadata =cut ######################################### ######################################### sub metaeval { my $metastring=shift; my $parser=HTML::LCParser->new(\$metastring); my $token; while ($token=$parser->get_token) { if ($token->[0] eq 'S') { my $entry=$token->[1]; my $unikey=$entry; if (defined($token->[2]->{'package'})) { $unikey.='_package_'.$token->[2]->{'package'}; } if (defined($token->[2]->{'part'})) { $unikey.='_'.$token->[2]->{'part'}; } if (defined($token->[2]->{'id'})) { $unikey.='_'.$token->[2]->{'id'}; } if (defined($token->[2]->{'name'})) { $unikey.='_'.$token->[2]->{'name'}; } foreach (@{$token->[3]}) { $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; if ($metadatakeys{$unikey}) { $metadatakeys{$unikey}.=','.$_; } else { $metadatakeys{$unikey}=$_; } } if ($metadatafields{$unikey}) { my $newentry=$parser->get_text('/'.$entry); unless (($metadatafields{$unikey}=~/$newentry/) || ($newentry eq '')) { $metadatafields{$unikey}.=', '.$newentry; } } else { $metadatafields{$unikey}=$parser->get_text('/'.$entry); } } } } ######################################### ######################################### =pod =item metaread Read a metadata file =cut ######################################### ######################################### sub metaread { my ($logfile,$fn)=@_; unless (-e $fn) { print $logfile 'No file '.$fn."\n"; return '<br><b>No file:</b> <tt>'.$fn.'</tt>'; } print $logfile 'Processing '.$fn."\n"; my $metastring; { my $metafh=Apache::File->new($fn); $metastring=join('',<$metafh>); } &metaeval($metastring); return '<br><b>Processed file:</b> <tt>'.$fn.'</tt>'; } ######################################### ######################################### =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($timef); $mon++; $year+=1900; return "$year-$mon-$mday $hour:$min:$sec"; } ######################################### ######################################### =pod =item Form field generating functions =over 4 =item textfield =item hiddenfield =item selectbox =back =cut ######################################### ######################################### sub textfield { my ($title,$name,$value)=@_; return "\n<p><b>$title:</b><br>". '<input type=text name="'.$name.'" size=80 value="'.$value.'">'; } sub hiddenfield { my ($name,$value)=@_; return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">'; } sub selectbox { my ($title,$name,$value,$functionref,@idlist)=@_; my $uctitle=uc($title); my $selout="\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:". "</b></font><br />".'<select name="'.$name.'">'; foreach (@idlist) { $selout.='<option value=\''.$_.'\''; if ($_ eq $value) { $selout.=' selected>'.&{$functionref}($_).'</option>'; } else {$selout.='>'.&{$functionref}($_).'</option>';} } return $selout.'</select>'; } ######################################### ######################################### =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\:\/\/)*([^\/]+)/); foreach (values %Apache::lonnet::hostname) { if ($_ eq $host) { $url=~s/^http\:\/\///; $url=~s/^$host//; } } 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); } 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 <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.'>'; if ($lctag eq 'm') { $outstring.=&get_all_text_unbalanced('/m',\@parser); } } 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); } ######################################### ######################################### =pod =item store_metadata Store the metadata in the metadata table in the loncapa database. Uses lonmysql to access the database. Inputs: \%metadata Returns: (error,status). error is undef on success, status is undef on error. =cut ######################################### ######################################### sub store_metadata { my %metadata = %{shift()}; my $error; # Determine if the table exists my $status = &Apache::lonmysql::check_table('metadata'); if (! defined($status)) { $error='<font color="red">WARNING: Cannot connect to '. 'database!</font>'; &Apache::lonnet::logthis($error); return ($error,undef); } if ($status == 0) { # It would be nice to actually create the table.... $error ='<font color="red">WARNING: The metadata table does not '. 'exist in the LON-CAPA database.</font>'; &Apache::lonnet::logthis($error); return ($error,undef); } # Remove old value from table $status = &Apache::lonmysql::remove_from_table ('metadata','url',$metadata{'url'}); if (! defined($status)) { $error = '<font color="red">Error when removing old values from '. 'metadata table in LON-CAPA database.</font>'; &Apache::lonnet::logthis($error); return ($error,undef); } # Store data in table. $status = &Apache::lonmysql::store_row('metadata',\%metadata); if (! defined($status)) { $error='<font color="red">Error occured storing new values in '. 'metadata table in LON-CAPA database</font>'; &Apache::lonnet::logthis($error); return ($error,undef); } return (undef,$status); } ######################################### ######################################### =pod =item publish Currently undocumented. This is the workhorse function of this module. =cut ######################################### ######################################### sub publish { my ($source,$target,$style)=@_; my $logfile; my $scrout=''; my $allmeta=''; my $content=''; my %allow=(); unless ($logfile=Apache::File->new('>>'.$source.'.log')) { return '<font color=red>No write permission to user directory, FAIL</font>'; } print $logfile "\n\n================= Publish ".localtime()." Phase One ================\n"; if (($style eq 'ssi') || ($style eq 'rat')) { # ------------------------------------------------------- This needs processing # ----------------------------------------------------------------- Backup Copy my $copyfile=$source.'.save'; if (copy($source,$copyfile)) { print $logfile "Copied original file to ".$copyfile."\n"; } else { print $logfile "Unable to write backup ".$copyfile.':'.$!."\n"; return "<font color=red>Failed to write backup copy, $!,FAIL</font>"; } # ------------------------------------------------------------- IDs and indices my $outstring; ($outstring,%allow)=&fix_ids_and_indices($logfile,$source,$target); # ------------------------------------------------------------ Construct Allows $scrout.='<h3>Dependencies</h3>'; my $allowstr=''; foreach (sort(keys(%allow))) { my $thisdep=$_; if ($thisdep !~ /[^\s]/) { next; } unless ($style eq 'rat') { $allowstr.="\n".'<allow src="'.$thisdep.'" />'; } $scrout.='<br>'; unless ($thisdep=~/\*/) { $scrout.='<a href="'.$thisdep.'">'; } $scrout.='<tt>'.$thisdep.'</tt>'; unless ($thisdep=~/\*/) { $scrout.='</a>'; if ( &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. $thisdep.'.meta') eq '-1') { $scrout.= ' - <font color=red>Currently not available</font>'; } 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); } } } } $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s; #Encode any High ASCII characters $outstring=&HTML::Entities::encode($outstring,"\200-\377"); # ------------------------------------------------------------- Write modified { my $org; unless ($org=Apache::File->new('>'.$source)) { print $logfile "No write permit to $source\n"; return "<font color=red>No write permission to $source, FAIL</font>"; } print $org $outstring; } $content=$outstring; } # --------------------------------------------- Initial step done, now metadata # ---------------------------------------- Storage for metadata keys and fields %metadatafields=(); %metadatakeys=(); my %oldparmstores=(); $scrout.='<h3>Metadata Information ' . Apache::loncommon::help_open_topic("Metadata_Description") . '</h3>'; # ------------------------------------------------ First, check out environment unless (-e $source.'.meta') { $metadatafields{'author'}=$ENV{'environment.firstname'}.' '. $ENV{'environment.middlename'}.' '. $ENV{'environment.lastname'}.' '. $ENV{'environment.generation'}; $metadatafields{'author'}=~s/\s+/ /g; $metadatafields{'author'}=~s/\s+$//; $metadatafields{'owner'}=$cuname.'@'.$cudom; # ------------------------------------------------ Check out directory hierachy my $thisdisfn=$source; $thisdisfn=~s/^\/home\/$cuname\///; my @urlparts=split(/\//,$thisdisfn); $#urlparts--; my $currentpath='/home/'.$cuname.'/'; foreach (@urlparts) { $currentpath.=$_.'/'; $scrout.=&metaread($logfile,$currentpath.'default.meta'); } # ------------------- Clear out parameters and stores (there should not be any) foreach (keys %metadatafields) { if (($_=~/^parameter/) || ($_=~/^stores/)) { delete $metadatafields{$_}; } } } else { # ---------------------- Read previous metafile, remember parameters and stores $scrout.=&metaread($logfile,$source.'.meta'); foreach (keys %metadatafields) { if (($_=~/^parameter/) || ($_=~/^stores/)) { $oldparmstores{$_}=1; delete $metadatafields{$_}; } } } # -------------------------------------------------- Parse content for metadata if ($style eq 'ssi') { my $oldenv=$ENV{'request.uri'}; $ENV{'request.uri'}=$target; $allmeta=Apache::lonxml::xmlparse(undef,'meta',$content); $ENV{'request.uri'}=$oldenv; &metaeval($allmeta); } # ---------------- Find and document discrepancies in the parameters and stores my $chparms=''; foreach (sort keys %metadatafields) { if (($_=~/^parameter/) || ($_=~/^stores/)) { unless ($_=~/\.\w+$/) { unless ($oldparmstores{$_}) { print $logfile 'New: '.$_."\n"; $chparms.=$_.' '; } } } } if ($chparms) { $scrout.='<p><b>New parameters or stored values:</b> '. $chparms; } $chparms=''; foreach (sort keys %oldparmstores) { if (($_=~/^parameter/) || ($_=~/^stores/)) { unless (($metadatafields{$_.'.name'}) || ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { print $logfile 'Obsolete: '.$_."\n"; $chparms.=$_.' '; } } } if ($chparms) { $scrout.='<p><b>Obsolete parameters or stored values:</b> '. $chparms; } # ------------------------------------------------------- Now have all metadata $scrout.= '<form name="pubform" action="/adm/publish" method="post">'. '<p><input type="submit" value="Finalize Publication" /></p>'. &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 $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords"); my $keywordout=<<"END"; <script> function checkAll(field) { for (i = 0; i < field.length; i++) field[i].checked = true ; } function uncheckAll(field) { for (i = 0; i < field.length; i++) field[i].checked = false ; } </script> <p><b>Keywords: $keywords_help</b> <input type="button" value="check all" onclick="javascript:checkAll(document.pubform.keywords)"> <input type="button" value="uncheck all" onclick="javascript:uncheckAll(document.pubform.keywords)"> <br /> END $keywordout.='<table border=2><tr>'; my $colcount=0; my %keywords=(); if (length($content)<500000) { my $textonly=$content; $textonly=~s/\<script[^\<]+\<\/script\>//g; $textonly=~s/\<m\>[^\<]+\<\/m\>//g; $textonly=~s/\<[^\>]*\>//g; $textonly=~tr/A-Z/a-z/; $textonly=~s/[\$\&][a-z]\w*//g; $textonly=~s/[^a-z\s]//g; foreach ($textonly=~m/(\w+)/g) { unless ($nokey{$_}) { $keywords{$_}=1; } } } foreach (split(/\W+/,$metadatafields{'keywords'})) { $keywords{$_}=1; } foreach (sort keys %keywords) { $keywordout.='<td><input type=checkbox name="keywords" value="'.$_.'"'; if ($metadatafields{'keywords'}) { if ($metadatafields{'keywords'}=~/$_/) { $keywordout.=' checked'; } } elsif (&Apache::loncommon::keyword($_)) { $keywordout.=' checked'; } $keywordout.='>'.$_.'</td>'; if ($colcount>10) { $keywordout.="</tr><tr>\n"; $colcount=0; } $colcount++; } $keywordout.='</tr></table>'; $scrout.=$keywordout; $scrout.=&textfield('Additional Keywords','addkey',''); $scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); $scrout.= '<p><b>Abstract:</b><br><textarea cols=80 rows=5 name=abstract>'. $metadatafields{'abstract'}.'</textarea>'; $source=~/\.(\w+)$/; $scrout.=&hiddenfield('mime',$1); $scrout.=&selectbox('Language','language', $metadatafields{'language'}, \&Apache::loncommon::languagedescription, (&Apache::loncommon::languageids), ); unless ($metadatafields{'creationdate'}) { $metadatafields{'creationdate'}=time; } $scrout.=&hiddenfield('creationdate',$metadatafields{'creationdate'}); $scrout.=&hiddenfield('lastrevisiondate',time); $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'}, \&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. '<p><input type="submit" value="Finalize Publication" /></p></form>'; } ######################################### ######################################### =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 '<font color=red>No write permission to user directory, FAIL</font>'; } print $logfile "\n================= Publish ".localtime()." Phase Two ================\n"; %metadatafields=(); %metadatakeys=(); &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'})); $metadatafields{'title'}=$ENV{'form.title'}; $metadatafields{'author'}=$ENV{'form.author'}; $metadatafields{'subject'}=$ENV{'form.subject'}; $metadatafields{'notes'}=$ENV{'form.notes'}; $metadatafields{'abstract'}=$ENV{'form.abstract'}; $metadatafields{'mime'}=$ENV{'form.mime'}; $metadatafields{'language'}=$ENV{'form.language'}; $metadatafields{'creationdate'}=$ENV{'form.creationdate'}; $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'}; if (exists($ENV{'form.keywords'}) && (ref($ENV{'form.keywords'}))) { my @Keywords = @{$ENV{'form.keywords'}}; foreach (@Keywords) { $allkeywords.=','.$_; } } $allkeywords=~s/\W+/\,/; $allkeywords=~s/^\,//; $metadatafields{'keywords'}=$allkeywords; { print $logfile "\nWrite metadata file for ".$source; my $mfh; unless ($mfh=Apache::File->new('>'.$source.'.meta')) { return '<font color=red>Could not write metadata, FAIL</font>'; } foreach (sort keys %metadatafields) { unless ($_=~/\./) { my $unikey=$_; $unikey=~/^([A-Za-z]+)/; my $tag=$1; $tag=~tr/A-Z/a-z/; print $mfh "\n\<$tag"; foreach (split(/\,/,$metadatakeys{$unikey})) { my $value=$metadatafields{$unikey.'.'.$_}; $value=~s/\"/\'\'/g; print $mfh ' '.$_.'="'.$value.'"'; } print $mfh '>'. &HTML::Entities::encode($metadatafields{$unikey}) .'</'.$tag.'>'; } } $scrout.='<p>Wrote Metadata'; print $logfile "\nWrote metadata"; } # -------------------------------- Synchronize entry with SQL metadata database my $warning; $metadatafields{'url'} = $distarget; $metadatafields{'version'} = 'current'; unless ($metadatafields{'copyright'} eq 'priv') { my ($error,$success) = &store_metadata(\%metadatafields); if ($success) { $scrout.='<p>Synchronized SQL metadata database'; print $logfile "\nSynchronized SQL metadata database"; } else { $warning.=$error; print $logfile "\n".$error; } } else { $scrout.='<p>Private Publication - did not synchronize database'; print $logfile "\nPrivate: Did not synchronize data into ". "SQL metadata database"; } # ----------------------------------------------------------- Copy old versions if (-e $target) { my $filename; my $maxversion=0; $target=~/(.*)\/([^\/]+)\.(\w+)$/; my $srcf=$2; my $srct=$3; my $srcd=$1; unless ($srcd=~/^\/home\/httpd\/html\/res/) { print $logfile "\nPANIC: Target dir is ".$srcd; return "<font color=red>Invalid target directory, FAIL</font>"; } opendir(DIR,$srcd); while ($filename=readdir(DIR)) { if ($filename=~/$srcf\.(\d+)\.$srct$/) { $maxversion=($1>$maxversion)?$1:$maxversion; } } closedir(DIR); $maxversion++; $scrout.='<p>Creating old version '.$maxversion; print $logfile "\nCreating old version ".$maxversion; my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct; if (copy($target,$copyfile)) { print $logfile "Copied old target to ".$copyfile."\n"; $scrout.='<p>Copied old target file'; } else { print $logfile "Unable to write ".$copyfile.':'.$!."\n"; return "<font color=red>Failed to copy old target, $!, FAIL</font>"; } # --------------------------------------------------------------- Copy Metadata $copyfile=$copyfile.'.meta'; if (copy($target.'.meta',$copyfile)) { print $logfile "Copied old target metadata to ".$copyfile."\n"; $scrout.='<p>Copied old metadata'; } else { print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; if (-e $target.'.meta') { return "<font color=red>Failed to write old metadata copy, $!, FAIL</font>"; } } } else { $scrout.='<p>Initial version'; print $logfile "\nInitial version"; } # ---------------------------------------------------------------- Write Source my $copyfile=$target; my @parts=split(/\//,$copyfile); my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; my $count; for ($count=5;$count<$#parts;$count++) { $path.="/$parts[$count]"; if ((-e $path)!=1) { print $logfile "\nCreating directory ".$path; $scrout.='<p>Created directory '.$parts[$count]; mkdir($path,0777); } } if (copy($source,$copyfile)) { print $logfile "Copied original source to ".$copyfile."\n"; $scrout.='<p>Copied source file'; } else { print $logfile "Unable to write ".$copyfile.':'.$!."\n"; return "<font color=red>Failed to copy source, $!, FAIL</font>"; } # --------------------------------------------------------------- Copy Metadata $copyfile=$copyfile.'.meta'; if (copy($source.'.meta',$copyfile)) { print $logfile "Copied original metadata to ".$copyfile."\n"; $scrout.='<p>Copied metadata'; } else { print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; return "<font color=red>Failed to write metadata copy, $!, FAIL</font>"; } # --------------------------------------------------- Send update notifications my @subscribed=&get_subscribed_hosts($target); foreach my $subhost (@subscribed) { $scrout.='<p>Notifying host '.$subhost.':'; print $logfile "\nNotifying host ".$subhost.':'; my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); $scrout.=$reply; print $logfile $reply; } # ---------------------------------------- Send update notifications, meta only my @subscribedmeta=&get_subscribed_hosts("$target.meta"); foreach my $subhost (@subscribedmeta) { $scrout.='<p>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; } # ------------------------------------------------ Provide link to new resource my $thisdistarget=$target; $thisdistarget=~s/^$docroot//; my $thissrc=$source; $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/; my $thissrcdir=$thissrc; $thissrcdir=~s/\/[^\/]+$/\//; return $warning.$scrout. '<hr><a href="'.$thisdistarget.'"><font size=+2>View Published Version</font></a>'. '<p><a href="'.$thissrc.'"><font size=+2>Back to Source</font></a>'. '<p><a href="'.$thissrcdir. '"><font size=+2>Back to Source Directory</font></a>'; } ######################################### ######################################### =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; if ($r->header_only) { $r->content_type('text/html'); $r->send_http_header; 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'}; unless ($fn) { $r->log_reason($cuname.' at '.$cudom. ' trying to publish empty filename', $r->filename); return HTTP_NOT_FOUND; } ($cuname,$cudom)= &Apache::loncacc::constructaccess($fn,$r->dir_config('lonDefDomain')); unless (($cuname) && ($cudom)) { $r->log_reason($cuname.' at '.$cudom. ' trying to publish file '.$ENV{'form.filename'}. ' ('.$fn.') - not authorized', $r->filename); return HTTP_NOT_ACCEPTABLE; } unless (&Apache::lonnet::homeserver($cuname,$cudom) eq $r->dir_config('lonHostID')) { $r->log_reason($cuname.' at '.$cudom. ' trying to publish file '.$ENV{'form.filename'}. ' ('.$fn.') - not homeserver ('. &Apache::lonnet::homeserver($cuname,$cudom).')', $r->filename); return HTTP_NOT_ACCEPTABLE; } $fn=~s/^http\:\/\/[^\/]+//; $fn=~s/^\/\~(\w+)/\/home\/$1\/public_html/; my $targetdir=''; $docroot=$r->dir_config('lonDocRoot'); if ($1 ne $cuname) { $r->log_reason($cuname.' at '.$cudom. ' trying to publish unowned file '.$ENV{'form.filename'}. ' ('.$fn.')', $r->filename); return HTTP_NOT_ACCEPTABLE; } else { $targetdir=$docroot.'/res/'.$cudom; } unless (-e $fn) { $r->log_reason($cuname.' at '.$cudom. ' trying to publish non-existing file '.$ENV{'form.filename'}. ' ('.$fn.')', $r->filename); return HTTP_NOT_FOUND; } unless ($ENV{'form.phase'} eq 'two') { # --------------------------------- File is there and owned, init lookup tables %addid=(); { my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab'); while (<$fh>=~/(\w+)\s+(\w+)/) { $addid{$1}=$2; } } %nokey=(); { my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); while (<$fh>) { my $word=$_; chomp($word); $nokey{$word}=1; } } } # ----------------------------------------------------------- Start page output $r->content_type('text/html'); $r->send_http_header; $r->print('<html><head><title>LON-CAPA Publishing</title></head>'); $r->print( '<body bgcolor="#FFFFFF"><img align=right src=/adm/lonIcons/lonlogos.gif>'); my $thisfn=$fn; # ------------------------------------------------------------- Individual file { $thisfn=~/\.(\w+)$/; my $thistype=$1; my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); my $thistarget=$thisfn; $thistarget=~s/^\/home/$targetdir/; $thistarget=~s/\/public\_html//; my $thisdistarget=$thistarget; $thisdistarget=~s/^$docroot//; my $thisdisfn=$thisfn; $thisdisfn=~s/^\/home\/$cuname\/public_html\///; $r->print('<h2>Publishing '. &Apache::loncommon::filedescription($thistype).' <tt>'. $thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>'); if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) { $r->print('<h3><font color=red>Co-Author: '.$cuname.' at '.$cudom. '</font></h3>'); } if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { $r->print('<br><a href="/adm/diff?filename=/~'.$cuname.'/'. $thisdisfn. '&versionone=priv" target=cat>Diffs with Current Version</a><p>'); } # ------------ We are publishing from $thisfn to $thistarget with $thisembstyle unless ($ENV{'form.phase'} eq 'two') { $r->print( '<hr>'.&publish($thisfn,$thistarget,$thisembstyle)); } else { $r->print( '<hr>'.&phasetwo($thisfn,$thistarget,$thisembstyle,$thisdistarget)); } } $r->print('</body></html>'); return OK; } 1; __END__ =pod =back =cut

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.