$title:
".
+ '';
+}
+
+sub hiddenfield {
+ my ($name,$value)=@_;
+ return "\n".'';
+}
+
+sub selectbox {
+ my ($title,$name,$value,$functionref,@idlist)=@_;
+ my $uctitle=uc($title);
+ my $selout="\n
$uctitle:".
+ "
".'';
+}
+
+# -------------------------------------------------------- Publication Step One
+
+sub urlfixup {
+ my ($url,$target)=@_;
+ unless ($url) { return ''; }
+ #javascript code needs no fixing
+ if ($url =~ /^javascript:/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/;
+ if ($target) {
+ $target=~s/\/[^\/]+$//;
+ $url=&Apache::lonnet::hreflocation($target,$url);
+ }
+ return $url;
+}
+
+sub publish {
+
+ my ($source,$target,$style)=@_;
+ my $logfile;
+ my $scrout='';
+ my $allmeta='';
+ my $content='';
+ my %allow=();
+ undef %allow;
+
+ unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
+ return
+ 'No write permission to user directory, FAIL';
+ }
+ 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 "Failed to write backup copy, $!,FAIL";
+ }
+# ------------------------------------------------------------- IDs and indices
+
+ my $maxindex=10;
+ my $maxid=10;
+
+ my $needsfixup=0;
+
+ {
+ my $org=Apache::File->new($source);
+ $content=join('',<$org>);
+ }
+ {
+ 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);
+ $parser->xml_mode(1);
+ my $token;
+ while ($token=$parser->get_token) {
+ if ($token->[0] eq 'S') {
+ my $counter;
+ my $tag=$token->[1];
+ my $lctag=lc($tag);
+ unless ($lctag eq 'allow') {
+ my %parms=%{$token->[2]};
+ $counter=$addid{$tag};
+ if (!$counter) { $counter=$addid{$lctag}; }
+ if ($counter) {
+ if ($counter eq 'id') {
+ unless (defined($parms{'id'})) {
+ $maxid++;
+ $parms{'id'}=$maxid;
+ print $logfile 'ID: '.$tag.':'.$maxid."\n";
+ }
+ } elsif ($counter eq 'index') {
+ unless (defined($parms{'index'})) {
+ $maxindex++;
+ $parms{'index'}=$maxindex;
+ print $logfile 'Index: '.$tag.':'.$maxindex."\n";
+ }
+ }
+ }
+
+ foreach ('src','href','background') {
+ 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;
+ }
+ }
+
+ 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 {
+ 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{$newurl}=1;
+ }
+ }
+ }
+ }
+
+ my $newparmstring='';
+ my $endtag='';
+ foreach (keys %parms) {
+ if ($_ eq '/') {
+ $endtag=' /';
+ } else {
+ my $quote=($parms{$_}=~/\"/?"'":'"');
+ $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
+ }
+ }
+ if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
+ $outstring.='<'.$tag.$newparmstring.$endtag.'>';
+ } else {
+ $allow{$token->[2]->{'src'}}=1;
+ }
+ } elsif ($token->[0] eq 'E') {
+ if ($token->[2]) {
+ unless ($token->[1] eq 'allow') {
+ $outstring.='[1].'>';
+ }
+ }
+ } else {
+ $outstring.=$token->[1];
+ }
+ }
+# ------------------------------------------------------------ Construct Allows
+
+ $scrout.='
New parameters or stored values: '. + $chparms; + } + + my $chparms=''; + foreach (sort keys %oldparmstores) { + if (($_=~/^parameter/) || ($_=~/^stores/)) { + unless (($metadatafields{$_.'.name'}) || + ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { + print $logfile 'Obsolete: '.$_."\n"; + $chparms.=$_.' '; + } + } + } + if ($chparms) { + $scrout.='
Obsolete parameters or stored values: '. + $chparms; + } + +# ------------------------------------------------------- Now have all metadata + + $scrout.= + '
'; +} + +# -------------------------------------------------------- Publication Step Two + +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'; + } + 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'}; + foreach (keys %ENV) { + if ($_=~/^form\.key\.(\w+)/) { + $allkeywords.=','.$1; + } + } + $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 + 'Could not write metadata, FAIL'; + } + 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 '>'.$metadatafields{$unikey}.''; + } + } + $scrout.='Wrote Metadata'; + print $logfile "\nWrote metadata"; + } + +# -------------------------------- Synchronize entry with SQL metadata database + my $warning; + + unless ($metadatafields{'copyright'} eq 'priv') { + + my $dbh; + { + unless ( + $dbh = DBI->connect("DBI:mysql:loncapa","www", + $Apache::lonnet::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(); + foreach ('title','author','subject','keywords','notes','abstract', + 'mime','language','creationdate','lastrevisiondate','owner', + 'copyright') { + my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g; + $sqldatafields{$_}=$field; + } + + $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"; + } + } + +} 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) { + 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 "Invalid target directory, FAIL"; + } + opendir(DIR,$srcd); + while ($filename=readdir(DIR)) { + if ($filename=~/$srcf\.(\d+)\.$srct$/) { + $maxversion=($1>$maxversion)?$1:$maxversion; + } + } + closedir(DIR); + $maxversion++; + $scrout.='
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.='
Copied old target file'; + } else { + print $logfile "Unable to write ".$copyfile.':'.$!."\n"; + return "Failed to copy old target, $!, FAIL"; + } + +# --------------------------------------------------------------- Copy Metadata + + $copyfile=$copyfile.'.meta'; + + if (copy($target.'.meta',$copyfile)) { + print $logfile "Copied old target metadata to ".$copyfile."\n"; + $scrout.='
Copied old metadata'; + } else { + print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; + if (-e $target.'.meta') { + return + "Failed to write old metadata copy, $!, FAIL"; + } + } + + +} else { + $scrout.='
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.='
Created directory '.$parts[$count]; + mkdir($path,0777); + } + } + + if (copy($source,$copyfile)) { + print $logfile "Copied original source to ".$copyfile."\n"; + $scrout.='
Copied source file'; + } else { + print $logfile "Unable to write ".$copyfile.':'.$!."\n"; + return "Failed to copy source, $!, FAIL"; + } + +# --------------------------------------------------------------- Copy Metadata + + $copyfile=$copyfile.'.meta'; + + if (copy($source.'.meta',$copyfile)) { + print $logfile "Copied original metadata to ".$copyfile."\n"; + $scrout.='
Copied metadata'; + } else { + print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; + return + "Failed to write metadata copy, $!, FAIL"; + } + +# --------------------------------------------------- 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; + } + } + } + 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; + } + } + } + closedir(DIR); + +} + +# ------------------------------------------------ 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. + '
Back to Source'. + '
Back to Source Directory'; + +} # ================================================================ Main Handler 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 + + 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; + if ($name eq 'filename') { + unless ($ENV{'form.'.$name}) { + $ENV{'form.'.$name}=$value; + } + } + } + + +# -------------------------------------------------------------- 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; - return OK if $r->header_only; - $r->print('
');
+ 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(''); + + if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) { + $r->print('
'); + } + +# ------------ We are publishing from $thisfn to $thistarget with $thisembstyle + + unless ($ENV{'form.phase'} eq 'two') { + $r->print( + '