[BACK]Return to lonpublisher.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / publisher

Diff for /loncom/publisher/lonpublisher.pm between versions 1.1 and 1.8

version 1.1, 2000/11/28 22:15:11 version 1.8, 2000/12/01 12:08:01
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,12/01 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}) {
     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 '<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 textfield {
       my ($title,$value)=@_;
       return "\n<p><b>$title:</b><br>".
              '<input type=text size=80 value="'.$value.'">';
   }
   
   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=();
        
        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+$//;
   
   # ------------------------------------------------ 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='';
           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;
           }
   
   # ------------------------------------------------------- Now have all metadata
   
           $scrout.=
        '<form action="/adm/publish" method="post">'.
        '<input type="hidden" name="phase" value="two">'.
        '<input type="hidden" name="filename" value="'.$ENV{'form.filename'}.'">'.
             &textfield('Title',$metadatafields{'title'}).
             &textfield('Author(s)',$metadatafields{'author'}).
     &textfield('Subject',$metadatafields{'subject'});
   
   # --------------------------------------------------- Scan content for keywords
   
    my $keywordout='<p><b>Keywords:</b><br><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="'.$_.'"';
                   if ($metadatafields{'keywords'}=~/$_/) { 
                      $keywordout.=' checked'; 
                   }
                   $keywordout.='>'.$_.'</td>';
                   if ($colcount>10) {
       $keywordout.="</tr><tr>\n";
                       $colcount=0;
                   }
                   $colcount++;
               } sort keys %keywords;
               $keywordout.='</tr></table>';
   
           }         
           
   # DEGUG
    
    $scrout.=$keywordout;
       }
       return $scrout.
         '<p><input type="submit" value="Finalize Publication"></form>';
   }
   
 # ================================================================ 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;
Removed from v.1.1  
changed lines
  Added in v.1.8

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>