--- loncom/publisher/lonpublisher.pm 2000/11/28 22:15:11 1.1 +++ loncom/publisher/lonpublisher.pm 2000/12/02 12:40:27 1.10 @@ -5,26 +5,513 @@ # # 05/29/00,05/30,10/11 Gerd Kortemeyer) # -# 11/28 Gerd Kortemeyer +# 11/28,11/29,11/30,12/01,12/02 Gerd Kortemeyer package Apache::lonpublisher; use strict; use Apache::File; -use Apache::Constants qw(:common); +use Apache::Constants qw(:common :http :methods); +use HTML::TokeParser; +use Apache::lonxml; +use Apache::structuretags; +use Apache::response; + +my %addid; +my %nokey; +my %language; +my %cprtag; + +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}) { + my $newentry=$parser->get_text('/'.$entry); + unless ($metadatafields{$unikey}=~/$newentry/) { + $metadatafields{$unikey}.=', '.$newentry; + } + } else { + $metadatafields{$unikey}=$parser->get_text('/'.$entry); + } + } + } +} + +sub metaread { + my ($logfile,$fn)=@_; + unless (-e $fn) { + print $logfile 'No file '.$fn."\n"; + return '
No file: '.$fn.''; + } + print $logfile 'Processing '.$fn."\n"; + my $metastring; + { + my $metafh=Apache::File->new($fn); + $metastring=join('',<$metafh>); + } + &metaeval($metastring); + return '
Processed file: '.$fn.''; +} + +sub textfield { + my ($title,$name,$value)=@_; + return "\n

$title:
". + ''; +} + +sub selectbox { + my ($title,$name,$value,%options)=@_; + my $selout="\n

$title:
".''; +} + +sub publish { + + my ($source,$target,$style)=@_; + my $logfile; + my $scrout=''; + + unless ($logfile=Apache::File->new('>>'.$source.'.log')) { + return + 'No write permission to user directory, FAIL'; + } + 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 "Failed to write backup copy, FAIL"; + } +# ------------------------------------------------------------- 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 + "No write permission to $source, FAIL"; + } + 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=(); + + my %oldparmstores=(); + +# ------------------------------------------------ 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'}=$ENV{'user.name'}.'@'.$ENV{'user.domain'}; + +# ------------------------------------------------ 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; + + } else { +# ---------------------- Read previous metafile, remember parameters and stores + + $scrout.=&metaread($logfile,$source.'.meta'); + + map { + if (($_=~/^parameter/) || ($_=~/^stores/)) { + $oldparmstores{$_}=1; + delete $metadatafields{$_}; + } + } keys %metadatafields; + + } + +# -------------------------------------------------- Parse content for metadata + + my $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.='

New parameters or stored values: '. + $chparms; + } + + my $chparms=''; + map { + if (($_=~/^parameter/) || ($_=~/^stores/)) { + unless (($metadatafields{$_}) || ($_=~/\.\w+$/)) { + print $logfile 'Obsolete: '.$_."\n"; + $chparms.=$_.' '; + } + } + } sort keys %oldparmstores; + if ($chparms) { + $scrout.='

Obsolete parameters or stored values: '. + $chparms; + } + +# ------------------------------------------------------- Now have all metadata + + $scrout.= + '

'. + ''. + ''. + &textfield('Title','title',$metadatafields{'title'}). + &textfield('Author(s)','author',$metadatafields{'author'}). + &textfield('Subject','subject',$metadatafields{'subject'}); + +# --------------------------------------------------- Scan content for keywords + + my $keywordout='

Keywords:
'; + my $colcount=0; + + { + my $textonly=$content; + $textonly=~s/\//g; + $textonly=~s/\[^\<]+\<\/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.='\n"; + $colcount=0; + } + $colcount++; + } sort keys %keywords; + $keywordout.='
'; + if ($colcount>10) { + $keywordout.="
'; + + } + + $scrout.=$keywordout; + + $scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); + + $scrout.= + '

Abstract:
'; + + $scrout.=&selectbox('Language','language', + $metadatafields{'language'},%language); + + $scrout.=&textfield('Publisher/Owner','owner', + $metadatafields{'owner'}); + + $scrout.=&selectbox('Copyright/Distribution','copyright', + $metadatafields{'copyright'},%cprtag); + + } + return $scrout. + '

'; +} # ================================================================ Main Handler sub handler { 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>; + } + + %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>; + } +# ----------------------------------------------------------- Start page output + $r->content_type('text/html'); $r->send_http_header; - return OK if $r->header_only; - $r->print('LON-CAPA Publishing'); $r->print(''); - $r->print('

'.$ENV{'form.filename'}.'

'); + 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('

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

Target: '.$thisdistarget.'

'); + +# ------------ We are publishing from $thisfn to $thistarget with $thisembstyle + + $r->print('

'.&publish($thisfn,$thistarget,$thisembstyle)); + + } + $r->print(''); return OK;