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

Diff for /loncom/publisher/lonpublisher.pm between versions 1.3 and 1.55

version 1.3, 2000/11/29 19:52:34 version 1.55, 2001/12/04 18:10:37
Line 1 Line 1
 # The LearningOnline Network with CAPA  # The LearningOnline Network with CAPA
 # Publication Handler  # Publication Handler
   #
   # $Id$
   #
   # 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  # (TeX Content Handler
 #  #
 # 05/29/00,05/30,10/11 Gerd Kortemeyer)  # 05/29/00,05/30,10/11 Gerd Kortemeyer)
 #  #
 # 11/28,11/29 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
   
 package Apache::lonpublisher;  package Apache::lonpublisher;
   
 use strict;  use strict;
 use Apache::File;  use Apache::File;
   use File::Copy;
 use Apache::Constants qw(:common :http :methods);  use Apache::Constants qw(:common :http :methods);
 use HTML::TokeParser;  use HTML::TokeParser;
   use Apache::lonxml;
   use Apache::lonhomework;
   use Apache::loncacc;
   use DBI;
   
 my %addid;  my %addid;
   my %nokey;
   my %language;
   my %cprtag;
   
   my %metadatafields;
   my %metadatakeys;
   
   my $docroot;
   
   my $cuname;
   my $cudom;
   
   # ----------------------------------------------- Evaluate string with metadata
   
   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]->{'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'}; 
         }
                  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/) ||
                             ($newentry eq '')) {
                        $metadatafields{$unikey}.=', '.$newentry;
     }
         } else {
                    $metadatafields{$unikey}=$parser->get_text('/'.$entry);
                 }
             }
          }
   }
   
   # -------------------------------------------------------- Read a metadata file
   
   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>';
   }
   
   # ---------------------------- convert 'time' format into a datetime sql format
   sub sqltime {
       my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
    localtime(@_[0]);
       $mon++; $year+=1900;
       return "$year-$mon-$mday $hour:$min:$sec";
   }
   
   # --------------------------------------------------------- Various form fields
   
   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,%options)=@_;
       my $selout="\n<p><b>$title:</b><br>".'<select name="'.$name.'">';
       map {
           $selout.='<option value="'.$_.'"';
           if ($_ eq $value) { $selout.=' selected'; }
           $selout.='>'.$options{$_}.'</option>';
       } sort keys %options;
       return $selout.'</select>';
   }
   
   # -------------------------------------------------------- Publication Step One
   
   sub urlfixup {
       my ($url,$target)=@_;
       unless ($url) { return ''; }
       my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/);
       map {
    if ($_ eq $host) {
       $url=~s/^http\:\/\///;
               $url=~s/^$host//;
           }
       } values %Apache::lonnet::hostname;
       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 {  sub publish {
   
     my ($source,$target,$style)=@_;      my ($source,$target,$style)=@_;
     my $logfile;      my $logfile;
       my $scrout='';
       my $allmeta='';
       my $content='';
       my %allow=();
       undef %allow;
   
     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {      unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
  return 'No write permission to user directory, FAIL';   return 
            '<font color=red>No write permission to user directory, FAIL</font>';
     }      }
     print $logfile       print $logfile 
 "\n\n================== Publish ".localtime()." =================\n";  "\n\n================= Publish ".localtime()." Phase One  ================\n";
   
     if (($style eq 'ssi') || ($style eq 'rat')) {      if (($style eq 'ssi') || ($style eq 'rat')) {
 # ------------------------------------------------------- This needs processing  # ------------------------------------------------------- This needs processing
   
   # ----------------------------------------------------------------- Backup Copy
  my $copyfile=$source.'.save';   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 $maxindex=10;
           my $maxid=10;
   
           my $needsfixup=0;
   
         {          {
     my $org=Apache::File->new($source);            my $org=Apache::File->new($source);
             my $cop=Apache::File->new('>'.$copyfile);            $content=join('',<$org>);
             while (my $line=<$org>) { print $cop $line; }  
         }          }
         if (-e $copyfile) {          {
     print $logfile "Copied original file to ".$copyfile."\n";            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=$tag;$lctag=~s/[A-Z]/[a-z]/g;
                   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";
     }
         }
     } 
                     
                     map {
                         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;
                         }
                     } ('src','href','background');
   
                     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 {
                           map {
                             if (defined($parms{$_})) {
         my $oldurl=$parms{$_};
                                 my $newurl=&urlfixup($oldurl,$target);
         $newurl=~s/\/[^\/]+$/\/\*/;
                                     print $logfile 'Allow: applet '.$_.':'.
                                     $oldurl.' allows '.
     $newurl."\n";
                                 $allow{$newurl}=1;
                             }
                           } ('archive','code','object');
                         }
                     }
   
                     my $newparmstring='';
                     my $endtag='';
                     map {
                       if ($_ eq '/') {
                         $endtag=' /';
                       } else { 
                         my $quote=($parms{$_}=~/\"/?"'":'"');
                         $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
       }
                     } keys %parms;
     
     $outstring.='<'.$tag.$newparmstring.$endtag.'>';
            } else {
      $allow{$token->[2]->{'src'}}=1;
    }
                 } elsif ($token->[0] eq 'E') {
                     unless ($token->[1] eq 'allow') {
                        $outstring.='</'.$token->[1].'>';
     }
                 } else {
                     $outstring.=$token->[1];
                 }
             }
   # ------------------------------------------------------------ Construct Allows
        unless ($style eq 'rat') {
    $scrout.='<h3>Dependencies</h3>';
    my $allowstr="\n";
           map {
              $allowstr.='<allow src="'.$_.'" />'."\n";
              $scrout.='<br>';
              unless ($_=~/\*/) {
          $scrout.='<a href="'.$_.'">';
              }
              $scrout.='<tt>'.$_.'</tt>';
              unless ($_=~/\*/) {
          $scrout.='</a>';
              }
           } keys %allow;
           $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s;
       }
   # ------------------------------------------------------------- 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;
   
         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";
         }
       }
   # --------------------------------------------- Initial step done, now metadata
   
   # ---------------------------------------- Storage for metadata keys and fields
   
        %metadatafields=();
        %metadatakeys=();
        
        my %oldparmstores=();
        
        $scrout.='<h3>Metadata Information</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.'/';
   
           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
       if ($style eq 'ssi') {
           my $oldenv=$ENV{'request.uri'};
   
           $ENV{'request.uri'}=$target;
           $allmeta=Apache::lonxml::xmlparse('meta',$content);
           $ENV{'request.uri'}=$oldenv;
   
           &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{$_.'.name'}) ||
                           ($metadatafields{$_.'.package'}) || ($_=~/\.\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">'.
             &hiddenfield('phase','two').
             &hiddenfield('filename',$ENV{'form.filename'}).
     &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).
             &textfield('Title','title',$metadatafields{'title'}).
             &textfield('Author(s)','author',$metadatafields{'author'}).
     &textfield('Subject','subject',$metadatafields{'subject'});
   
   # --------------------------------------------------- Scan content for keywords
   
    my $keywordout='<p><b>Keywords:</b><br><table border=2><tr>';
           my $colcount=0;
           
    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;
   
               my %keywords=();
               map {
    unless ($nokey{$_}) {
                      $keywords{$_}=1;
                   } 
               } ($textonly=~m/(\w+)/g);
   
               map {
    $keywords{$_}=1;
               } split(/\W+/,$metadatafields{'keywords'});
   
               map {
                   $keywordout.='<td><input type=checkbox name="key.'.$_.'"';
                   if ($metadatafields{'keywords'}=~/$_/) { 
                      $keywordout.=' checked'; 
                   }
                   $keywordout.='>'.$_.'</td>';
                   if ($colcount>10) {
       $keywordout.="</tr><tr>\n";
                       $colcount=0;
                   }
                   $colcount++;
               } sort keys %keywords;
   
         } else {          } else {
             return "Failed to write backup copy, FAIL";      $keywordout.='<td>File too long for keyword analysis</td>';
           }         
           
    $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'},%language);
   
           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'};
          }
          delete $cprtag{'public'};
      }
   
           $scrout.=&selectbox('Copyright/Distribution','copyright',
                               $metadatafields{'copyright'},%cprtag);
   
       return $scrout.
         '<p><input type="submit" value="Finalize Publication"></form>';
   }
   
   # -------------------------------------------------------- Publication Step Two
   
   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'};
   
        my $allkeywords=$ENV{'form.addkey'};
        map {
            if ($_=~/^form\.key\.(\w+)/) {
        $allkeywords.=','.$1;
            }
        } keys %ENV;
        $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>';
          }    
          map {
    unless ($_=~/\./) {
              my $unikey=$_;
              $unikey=~/^([A-Za-z]+)/;
              my $tag=$1;
              $tag=~tr/A-Z/a-z/;
              print $mfh "\n\<$tag";
              map {
                  my $value=$metadatafields{$unikey.'.'.$_};
                  $value=~s/\"/\'\'/g;
                  print $mfh ' '.$_.'="'.$value.'"';
              } split(/\,/,$metadatakeys{$unikey});
      print $mfh '>'.$metadatafields{$unikey}.'</'.$tag.'>';
            }
          } sort keys %metadatafields;
          $scrout.='<p>Wrote Metadata';
          print $logfile "\nWrote metadata";
        }
   
   # -------------------------------- Synchronize entry with SQL metadata database
       my %perlvar;
       open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
       my $configline;
       while ($configline=<CONFIG>) {
    if ($configline =~ /PerlSetVar/) {
       my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
       chomp($varvalue);
       $perlvar{$varname}=$varvalue;
    }
     }      }
     my $version='';      close(CONFIG);
   
       my $warning;
       my $dbh;
       {
    unless (
    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
    ) { 
       $warning='<font color=red>WARNING: Cannot connect to '.
    'database!</font>';
    }
    else {
       my %sqldatafields;
       $sqldatafields{'url'}=$distarget;
       my $sth=$dbh->prepare(
     'delete from metadata where url like binary'.
     '"'.$sqldatafields{'url'}.'"');
       $sth->execute();
       map {my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g; 
    $sqldatafields{$_}=$field;}
       ('title','author','subject','keywords','notes','abstract',
        'mime','language','creationdate','lastrevisiondate','owner',
        'copyright');
       
       $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.='<p>Synchronized SQL metadata database';
       print $logfile "\nSynchronized SQL metadata database";
    }
       }
   
   
   # ----------------------------------------------------------- Copy old versions
         
     return 'Version '.$version.', SUCCESS';  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 $filename;
    
       $target=~/(.*)\/([^\/]+)$/;
       my $srcf=$2;
       opendir(DIR,$1);
       while ($filename=readdir(DIR)) {
          if ($filename=~/$srcf\.(\w+)$/) {
      my $subhost=$1;
              if ($subhost ne 'meta') {
          $scrout.='<p>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.=
                   '<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;              
              }
          }
       }
       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.
         '<hr><a href="'.$thisdistarget.'"><font size=+2>View Target</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>';
   
 }  }
   
 # ================================================================ Main Handler  # ================================================================ Main Handler
Line 56  sub handler { Line 887  sub handler {
      return OK;       return OK;
   }    }
   
   # Get query string for limited number of parameters
   
       map {
          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;
      }
          }
       } (split(/&/,$ENV{'QUERY_STRING'}));
   
   
 # -------------------------------------------------------------- Check filename  # -------------------------------------------------------------- Check filename
   
   my $fn=$ENV{'form.filename'};    my $fn=$ENV{'form.filename'};
   
     
   unless ($fn) {     unless ($fn) { 
      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.       $r->log_reason($cuname.' at '.$cudom.
          ' trying to publish empty filename', $r->filename);            ' trying to publish empty filename', $r->filename); 
      return HTTP_NOT_FOUND;       return HTTP_NOT_FOUND;
   }     } 
   
   $fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/;    ($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='';    my $targetdir='';
   my $docroot=$r->dir_config('lonDocRoot');     $docroot=$r->dir_config('lonDocRoot'); 
   if ($1 ne $ENV{'user.name'}) {    if ($1 ne $cuname) {
      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.       $r->log_reason($cuname.' at '.$cudom.
          ' trying to publish unowned file '.$ENV{'form.filename'}.           ' trying to publish unowned file '.$ENV{'form.filename'}.
          ' ('.$fn.')',            ' ('.$fn.')', 
          $r->filename);            $r->filename); 
      return HTTP_NOT_ACCEPTABLE;       return HTTP_NOT_ACCEPTABLE;
   } else {    } else {
       $targetdir=$docroot.'/res/'.$ENV{'user.domain'};        $targetdir=$docroot.'/res/'.$cudom;
   }    }
                                                                     
       
   unless (-e $fn) {     unless (-e $fn) { 
      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.       $r->log_reason($cuname.' at '.$cudom.
          ' trying to publish non-existing file '.$ENV{'form.filename'}.           ' trying to publish non-existing file '.$ENV{'form.filename'}.
          ' ('.$fn.')',            ' ('.$fn.')', 
          $r->filename);            $r->filename); 
      return HTTP_NOT_FOUND;       return HTTP_NOT_FOUND;
   }     } 
   
   unless ($ENV{'form.phase'} eq 'two') {
   
 # --------------------------------- File is there and owned, init lookup tables  # --------------------------------- File is there and owned, init lookup tables
   
   %addid=();    %addid=();
Line 99  sub handler { Line 968  sub handler {
           $addid{$1}=$2;            $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  # ----------------------------------------------------------- Start page output
   
   $r->content_type('text/html');    $r->content_type('text/html');
   $r->send_http_header;    $r->send_http_header;
   
   $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"><img align=right src=/adm/lonIcons/lonlogos.gif>');
   my $thisfn=$fn;    my $thisfn=$fn;
         
 # ------------------------------------------------------------- Individual file  # ------------------------------------------------------------- Individual file
Line 123  sub handler { Line 1027  sub handler {
       $thisdistarget=~s/^$docroot//;        $thisdistarget=~s/^$docroot//;
   
       my $thisdisfn=$thisfn;        my $thisdisfn=$thisfn;
       $thisdisfn=~s/^\/home\/$ENV{'user.name'}\/public_html\///;        $thisdisfn=~s/^\/home\/$cuname\/public_html\///;
   
       $r->print('<h2>Publishing '.        $r->print('<h2>Publishing '.
         &Apache::lonnet::filedescription($thistype).' <tt>'.          &Apache::lonnet::filedescription($thistype).' <tt>'.
         $thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>');          $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::lonnet::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  # ------------ We are publishing from $thisfn to $thistarget with $thisembstyle
   
       $r->print('<b>Result:</b> '.&publish($thisfn,$thistarget,$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>');    $r->print('</body></html>');
   
   return OK;    return OK;
Removed from v.1.3  
changed lines
  Added in v.1.55

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