version 1.1, 2000/11/28 22:15:11
|
version 1.7, 2000/11/30 23:01:41
|
Line 5
|
Line 5
|
# |
# |
# 05/29/00,05/30,10/11 Gerd Kortemeyer) |
# 05/29/00,05/30,10/11 Gerd Kortemeyer) |
# |
# |
# 11/28 Gerd Kortemeyer |
# 11/28,11/29,11/30 Gerd Kortemeyer |
|
|
package Apache::lonpublisher; |
package Apache::lonpublisher; |
|
|
use strict; |
use strict; |
use Apache::File; |
use Apache::File; |
use Apache::Constants qw(:common); |
use Apache::Constants qw(:common :http :methods); |
|
use HTML::TokeParser; |
|
use Apache::lonxml; |
|
use Apache::lonhomework; |
|
|
|
my %addid; |
|
my %nokey; |
|
|
|
my %metadatafields; |
|
my %metadatakeys; |
|
|
|
sub metaeval { |
|
my $metastring=shift; |
|
|
|
my $parser=HTML::TokeParser->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]->{'part'})) { |
|
$unikey.='_'.$token->[2]->{'part'}; |
|
} |
|
if (defined($token->[2]->{'name'})) { |
|
$unikey.='_'.$token->[2]->{'name'}; |
|
} |
|
map { |
|
$metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; |
|
if ($metadatakeys{$unikey}) { |
|
$metadatakeys{$unikey}.=','.$_; |
|
} else { |
|
$metadatakeys{$unikey}=$_; |
|
} |
|
} @{$token->[3]}; |
|
if ($metadatafields{$unikey}) { |
|
$metadatafields{$unikey}.=','.$parser->get_text('/'.$entry); |
|
} else { |
|
$metadatafields{$unikey}=$parser->get_text('/'.$entry); |
|
} |
|
} |
|
} |
|
} |
|
|
|
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>'; |
|
} |
|
|
|
sub publish { |
|
|
|
my ($source,$target,$style)=@_; |
|
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\n================== Publish ".localtime()." =================\n"; |
|
|
|
if (($style eq 'ssi') || ($style eq 'rat')) { |
|
# ------------------------------------------------------- This needs processing |
|
|
|
# ----------------------------------------------------------------- Backup Copy |
|
my $copyfile=$source.'.save'; |
|
{ |
|
my $org=Apache::File->new($source); |
|
my $cop=Apache::File->new('>'.$copyfile); |
|
while (my $line=<$org>) { print $cop $line; } |
|
} |
|
if (-e $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 $maxindex=10; |
|
my $maxid=10; |
|
my $content=''; |
|
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); |
|
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'})) { |
|
$outstring.=$token->[4]; |
|
} else { |
|
$maxid++; |
|
my $thisid=' id="'.$maxid.'"'; |
|
my $fixup=$token->[4]; |
|
$fixup=~s/(\<\w+)/$1$thisid/; |
|
$outstring.=$fixup; |
|
print $logfile 'ID: '.$fixup."\n"; |
|
} |
|
} else { |
|
if (defined($token->[2]->{'index'})) { |
|
$outstring.=$token->[4]; |
|
} else { |
|
$maxindex++; |
|
my $thisindex=' index="'.$maxindex.'"'; |
|
my $fixup=$token->[4]; |
|
$fixup=~s/(\<\w+)/$1$thisindex/; |
|
$outstring.=$fixup; |
|
print $logfile 'Index: '.$fixup."\n"; |
|
} |
|
} |
|
} else { |
|
$outstring.=$token->[4]; |
|
} |
|
} elsif ($token->[0] eq 'E') { |
|
$outstring.=$token->[2]; |
|
} else { |
|
$outstring.=$token->[1]; |
|
} |
|
} |
|
{ |
|
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; |
|
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 |
|
|
|
# ---------------------------------------- Storage for metadata keys and fields |
|
|
|
%metadatafields=(); |
|
%metadatakeys=(); |
|
|
|
# ------------------------------------------------ First, check out environment |
|
|
|
$metadatafields{'author'}=$ENV{'environment.firstname'}.' '. |
|
$ENV{'environment.middlename'}.' '. |
|
$ENV{'environment.lastname'}.' '. |
|
$ENV{'environment.generation'}; |
|
|
|
# ------------------------------------------------ Check out directory hierachy |
|
|
|
my $thisdisfn=$source; |
|
$thisdisfn=~s/^\/home\/$ENV{'user.name'}\///; |
|
|
|
my @urlparts=split(/\//,$thisdisfn); |
|
$#urlparts--; |
|
|
|
my $currentpath='/home/'.$ENV{'user.name'}.'/'; |
|
|
|
map { |
|
$currentpath.=$_.'/'; |
|
$scrout.=&metaread($logfile,$currentpath.'default.meta'); |
|
} @urlparts; |
|
|
|
# ------------------- Clear out parameters and stores (there should not be any) |
|
|
|
map { |
|
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
|
delete $metadatafields{$_}; |
|
} |
|
} keys %metadatafields; |
|
|
|
# ---------------------- Read previous metafile, remember parameters and stores |
|
|
|
$scrout.=&metaread($logfile,$source.'.meta'); |
|
my %oldparmstores=(); |
|
|
|
map { |
|
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
|
$oldparmstores{$_}=1; |
|
delete $metadatafields{$_}; |
|
} |
|
} keys %metadatafields; |
|
|
|
|
|
|
|
# -------------------------------------------------- Parse content for metadata |
|
|
|
my $allmeta=''; |
|
if ($source=~/\.problem$/) { |
|
$allmeta=Apache::lonhomework::subhandler('meta',$content); |
|
} else { |
|
$allmeta=Apache::lonxml::xmlparse('meta',$content); |
|
} |
|
&metaeval($allmeta); |
|
|
|
# ---------------- Find and document discrepancies in the parameters and stores |
|
|
|
my $chparms=''; |
|
map { |
|
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
|
unless ($_=~/\.\w+$/) { |
|
unless ($oldparmstores{$_}) { |
|
print $logfile 'New: '.$_."\n"; |
|
$chparms.=$_.' '; |
|
} |
|
} |
|
} |
|
} sort keys %metadatafields; |
|
if ($chparms) { |
|
$scrout.='<p><b>New parameters or stored values:</b> '. |
|
$chparms; |
|
} |
|
|
|
my $chparms=''; |
|
map { |
|
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
|
unless (($metadatafields{$_}) || ($_=~/\.\w+$/)) { |
|
print $logfile 'Obsolete: '.$_."\n"; |
|
$chparms.=$_.' '; |
|
} |
|
} |
|
} sort keys %oldparmstores; |
|
if ($chparms) { |
|
$scrout.='<p><b>Obsolete parameters or stored values:</b> '. |
|
$chparms; |
|
} |
|
|
|
# DEBUG: |
|
|
|
$scrout.=$allmeta; |
|
|
|
# --------------------------------------------------- Scan content for keywords |
|
|
|
my $keywordout='<table border=2><tr>'; |
|
my $colcount=0; |
|
|
|
{ |
|
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; |
|
|
|
my %keywords=(); |
|
map { |
|
unless ($nokey{$_}) { |
|
$keywords{$_}=1; |
|
} |
|
} ($textonly=~m/(\w+)/g); |
|
|
|
|
|
map { |
|
$keywordout.='<td><input type=checkbox name="'.$_.'">'.$_. |
|
'</td>'; |
|
if ($colcount>10) { |
|
$keywordout.="</tr><tr>\n"; |
|
$colcount=0; |
|
} |
|
$colcount++; |
|
} sort keys %keywords; |
|
$keywordout.='</tr></table>'; |
|
|
|
} |
|
|
|
# DEGUG |
|
|
|
$scrout.=$keywordout; |
|
} |
|
return $scrout; |
|
} |
|
|
# ================================================================ Main Handler |
# ================================================================ Main Handler |
|
|
sub handler { |
sub handler { |
my $r=shift; |
my $r=shift; |
|
|
|
if ($r->header_only) { |
|
$r->content_type('text/html'); |
|
$r->send_http_header; |
|
return OK; |
|
} |
|
|
|
# -------------------------------------------------------------- Check filename |
|
|
|
my $fn=$ENV{'form.filename'}; |
|
|
|
unless ($fn) { |
|
$r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. |
|
' trying to publish empty filename', $r->filename); |
|
return HTTP_NOT_FOUND; |
|
} |
|
|
|
unless ($ENV{'user.home'} eq $r->dir_config('lonHostID')) { |
|
$r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. |
|
' trying to publish file '.$ENV{'form.filename'}. |
|
' ('.$fn.') - not homeserver ('.$ENV{'user.home'}.')', |
|
$r->filename); |
|
return HTTP_NOT_ACCEPTABLE; |
|
} |
|
|
|
$fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/; |
|
|
|
my $targetdir=''; |
|
my $docroot=$r->dir_config('lonDocRoot'); |
|
if ($1 ne $ENV{'user.name'}) { |
|
$r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. |
|
' trying to publish unowned file '.$ENV{'form.filename'}. |
|
' ('.$fn.')', |
|
$r->filename); |
|
return HTTP_NOT_ACCEPTABLE; |
|
} else { |
|
$targetdir=$docroot.'/res/'.$ENV{'user.domain'}; |
|
} |
|
|
|
|
|
unless (-e $fn) { |
|
$r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. |
|
' trying to publish non-existing file '.$ENV{'form.filename'}. |
|
' ('.$fn.')', |
|
$r->filename); |
|
return HTTP_NOT_FOUND; |
|
} |
|
|
|
# --------------------------------- 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'); |
|
map { |
|
my $word=$_; |
|
chomp($word); |
|
$nokey{$word}=1; |
|
} <$fh>; |
|
} |
|
# ----------------------------------------------------------- Start page output |
|
|
$r->content_type('text/html'); |
$r->content_type('text/html'); |
$r->send_http_header; |
$r->send_http_header; |
|
|
return OK if $r->header_only; |
|
|
|
$r->print('<html><head><title>LON-CAPA Publishing</title></head>'); |
$r->print('<html><head><title>LON-CAPA Publishing</title></head>'); |
$r->print('<body bgcolor="#FFFFFF">'); |
$r->print('<body bgcolor="#FFFFFF">'); |
$r->print('<h1>'.$ENV{'form.filename'}.'</h1>'); |
my $thisfn=$fn; |
|
|
|
# ------------------------------------------------------------- Individual file |
|
{ |
|
$thisfn=~/\.(\w+)$/; |
|
my $thistype=$1; |
|
my $thisembstyle=&Apache::lonnet::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\/$ENV{'user.name'}\/public_html\///; |
|
|
|
$r->print('<h2>Publishing '. |
|
&Apache::lonnet::filedescription($thistype).' <tt>'. |
|
$thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>'); |
|
|
|
# ------------ We are publishing from $thisfn to $thistarget with $thisembstyle |
|
|
|
$r->print('<hr>'.&publish($thisfn,$thistarget,$thisembstyle)); |
|
|
|
} |
|
|
$r->print('</body></html>'); |
$r->print('</body></html>'); |
|
|
return OK; |
return OK; |