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

Diff for /loncom/publisher/lonpublisher.pm between versions 1.89 and 1.120

version 1.89, 2002/08/09 17:57:48 version 1.120, 2003/03/29 05:58:12
Line 33 Line 33
 # 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer  # 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer
 # 03/23 Guy Albertelli  # 03/23 Guy Albertelli
 # 03/24,03/29,04/03 Gerd Kortemeyer  # 03/24,03/29,04/03 Gerd Kortemeyer
 # 04/16/2001 Scott Harrison  
 # 05/03,05/05,05/07 Gerd Kortemeyer  # 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  # 06/23,08/07,08/11,8/13,8/17,8/18,8/24,9/26,10/16 Gerd Kortemeyer
 # 12/04,12/05 Guy Albertelli  # 12/04,12/05 Guy Albertelli
 # 12/05 Gerd Kortemeyer  # 12/05 Gerd Kortemeyer
 # 12/05 Guy Albertelli  # 12/05 Guy Albertelli
 # 12/06,12/07 Gerd Kortemeyer  # 12/06,12/07 Gerd Kortemeyer
 # 12/15,12/16 Scott Harrison  
 # 12/25 Gerd Kortemeyer  # 12/25 Gerd Kortemeyer
 # YEAR=2002  # YEAR=2002
 # 1/16,1/17 Scott Harrison  
 # 1/17 Gerd Kortemeyer  # 1/17 Gerd Kortemeyer
 #  #
 ###  ###
Line 61 Line 57
 ##                                                                           ##  ##                                                                           ##
 ###############################################################################  ###############################################################################
   
   
   ######################################################################
   ######################################################################
   
   =pod 
   
   =head1 NAME
   
   lonpublisher - LON-CAPA publishing handler
   
   =head1 SYNOPSIS
   
   B<lonpublisher> is used by B<mod_perl> inside B<Apache>.  This is the
   invocation by F<loncapa_apache.conf>:
   
     <Location /adm/publish>
     PerlAccessHandler       Apache::lonacc
     SetHandler perl-script
     PerlHandler Apache::lonpublisher
     ErrorDocument     403 /adm/login
     ErrorDocument     404 /adm/notfound.html
     ErrorDocument     406 /adm/unauthorized.html
     ErrorDocument     500 /adm/errorhandler
     </Location>
   
   =head1 DESCRIPTION
   
   B<lonpublisher> takes the proper steps to add resources to the LON-CAPA
   digital library.  This includes updating the metadata table in the
   LON-CAPA database.
   
   B<lonpublisher> is many things to many people.  
   
   This module publishes a file.  This involves gathering metadata,
   versioning the file, copying file from construction space to
   publication space, and copying metadata from construction space
   to publication space.
   
   =head2 SUBROUTINES
   
   Many of the undocumented subroutines implement various magical
   parsing shortcuts.
   
   =over 4
   
   =cut
   
   ######################################################################
   ######################################################################
   
   
 package Apache::lonpublisher;  package Apache::lonpublisher;
   
 # ------------------------------------------------- modules used by this module  # ------------------------------------------------- modules used by this module
Line 70  use File::Copy; Line 117  use File::Copy;
 use Apache::Constants qw(:common :http :methods);  use Apache::Constants qw(:common :http :methods);
 use HTML::LCParser;  use HTML::LCParser;
 use Apache::lonxml;  use Apache::lonxml;
 use Apache::lonhomework;  
 use Apache::loncacc;  use Apache::loncacc;
 use DBI;  use DBI;
 use Apache::lonnet();  use Apache::lonnet();
 use Apache::loncommon();  use Apache::loncommon();
 use Apache::lonmysql;  use Apache::lonmysql;
   use vars qw(%metadatafields %metadatakeys);
   
 my %addid;  my %addid;
 my %nokey;  my %nokey;
   
 my %metadatafields;  
 my %metadatakeys;  
   
 my $docroot;  my $docroot;
   
 my $cuname;  my $cuname;
 my $cudom;  my $cudom;
   
 # ----------------------------------------------- Evaluate string with metadata  =pod
   
   =item B<metaeval>
   
   Evaluates a string that contains metadata.  This subroutine
   stores values inside I<%metadatafields> and I<%metadatakeys>.
   The hash key is a I<$unikey> corresponding to a unique id
   that is descriptive of the parser location inside the XML tree.
   
   Parameters:
   
   =over 4
   
   =item I<$metastring>
   
   A string that contains metadata.
   
   =back
   
   Returns:
   
   nothing
   
   =cut
   
   #########################################
   #########################################
 sub metaeval {  sub metaeval {
     my $metastring=shift;      my $metastring=shift;
         
Line 131  sub metaeval { Line 201  sub metaeval {
        }         }
 }  }
   
 # -------------------------------------------------------- Read a metadata file  #########################################
   #########################################
   
   =pod
   
   =item B<metaread>
   
   Read a metadata file
   
   Parameters:
   
   =over
   
   =item I<$logfile>
   
   File output stream to output errors and warnings to.
   
   =item I<$fn>
   
   File name (including path).
   
   =back
   
   Returns:
   
   =over 4
   
   =item Scalar string (if successful)
   
   XHTML text that indicates successful reading of the metadata.
   
   =back
   
   =cut
   
   #########################################
   #########################################
 sub metaread {  sub metaread {
     my ($logfile,$fn)=@_;      my ($logfile,$fn)=@_;
     unless (-e $fn) {      unless (-e $fn) {
  print $logfile 'No file '.$fn."\n";   print($logfile 'No file '.$fn."\n");
         return '<br><b>No file:</b> <tt>'.$fn.'</tt>';          return '<br /><b>No file:</b> <tt>'.$fn.'</tt>';
     }      }
     print $logfile 'Processing '.$fn."\n";      print($logfile 'Processing '.$fn."\n");
     my $metastring;      my $metastring;
     {      {
      my $metafh=Apache::File->new($fn);       my $metafh=Apache::File->new($fn);
      $metastring=join('',<$metafh>);       $metastring=join('',<$metafh>);
     }      }
     &metaeval($metastring);      &metaeval($metastring);
     return '<br><b>Processed file:</b> <tt>'.$fn.'</tt>';      return '<br /><b>Processed file:</b> <tt>'.$fn.'</tt>';
 }  }
   
 # ---------------------------- convert 'time' format into a datetime sql format  #########################################
 sub sqltime {  #########################################
     my $timef=shift @_;  
     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =  sub coursedependencies {
  localtime($timef);      my $url=&Apache::lonnet::declutter(shift);
     $mon++; $year+=1900;      $url=~s/\.meta$//;
     return "$year-$mon-$mday $hour:$min:$sec";      my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//);
       my $regexp=$url;
       $regexp=~s/(\W)/\\$1/g;
       $regexp='___'.$regexp.'___course';
       my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain,
          $aauthor,$regexp);
       my %courses=();
       foreach (keys %evaldata) {
    if ($_=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) {
       $courses{$1}=1;
           }
       }
       return %courses;
 }  }
   #########################################
   #########################################
   
   
   =pod
   
   =item Form-field-generating subroutines.
   
   For input parameters, these subroutines take in values
   such as I<$name>, I<$value> and other form field metadata.
   The output (scalar string that is returned) is an XHTML
   string which presents the form field (foreseeably inside
   <form></form> tags).
   
   =over 4
   
   =item B<textfield>
   
   =item B<hiddenfield>
   
   =item B<selectbox>
   
   =back
   
 # --------------------------------------------------------- Various form fields  =cut
   
   #########################################
   #########################################
 sub textfield {  sub textfield {
     my ($title,$name,$value)=@_;      my ($title,$name,$value)=@_;
     return "\n<p><b>$title:</b><br>".      return "\n<p><b>$title:</b></p><br />".
            '<input type=text name="'.$name.'" size=80 value="'.$value.'">';             '<input type="text" name="'.$name.'" size=80 value="'.$value.'" />';
 }  }
   
 sub hiddenfield {  sub hiddenfield {
     my ($name,$value)=@_;      my ($name,$value)=@_;
     return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">';      return "\n".'<input type="hidden" name="'.$name.'" value="'.$value.'" />';
 }  }
   
 sub selectbox {  sub selectbox {
     my ($title,$name,$value,$functionref,@idlist)=@_;      my ($title,$name,$value,$functionref,@idlist)=@_;
     my $uctitle=uc($title);      my $uctitle=uc($title);
     my $selout="\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".      my $selout="\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".
  "</b></font><br />".'<select name="'.$name.'">';   "</b></font></p><br />".'<select name="'.$name.'">';
     foreach (@idlist) {      foreach (@idlist) {
         $selout.='<option value=\''.$_.'\'';          $selout.='<option value=\''.$_.'\'';
         if ($_ eq $value) {          if ($_ eq $value) {
Line 185  sub selectbox { Line 328  sub selectbox {
     return $selout.'</select>';      return $selout.'</select>';
 }  }
   
 # -------------------------------------------------------- Publication Step One  #########################################
   #########################################
   
   =pod
   
   =item B<urlfixup>
   
   Fix up a url?  First step of publication
   
   =cut
   
   #########################################
   #########################################
 sub urlfixup {  sub urlfixup {
     my ($url,$target)=@_;      my ($url,$target)=@_;
     unless ($url) { return ''; }      unless ($url) { return ''; }
Line 207  sub urlfixup { Line 361  sub urlfixup {
     return $url;      return $url;
 }  }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<absoluteurl>
   
   Currently undocumented.
   
   =cut
   
   #########################################
   #########################################
 sub absoluteurl {  sub absoluteurl {
     my ($url,$target)=@_;      my ($url,$target)=@_;
     unless ($url) { return ''; }      unless ($url) { return ''; }
Line 218  sub absoluteurl { Line 384  sub absoluteurl {
     return $url;      return $url;
 }  }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<set_allow>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
 sub set_allow {  sub set_allow {
     my ($allow,$logfile,$target,$tag,$oldurl)=@_;      my ($allow,$logfile,$target,$tag,$oldurl)=@_;
     my $newurl=&urlfixup($oldurl,$target);      my $newurl=&urlfixup($oldurl,$target);
Line 236  sub set_allow { Line 415  sub set_allow {
     return $return_url      return $return_url
 }  }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<get_subscribed_hosts>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
 sub get_subscribed_hosts {  sub get_subscribed_hosts {
     my ($target)=@_;      my ($target)=@_;
     my @subscribed;      my @subscribed;
Line 244  sub get_subscribed_hosts { Line 436  sub get_subscribed_hosts {
     my $srcf=$2;      my $srcf=$2;
     opendir(DIR,$1);      opendir(DIR,$1);
     while ($filename=readdir(DIR)) {      while ($filename=readdir(DIR)) {
  if ($filename=~/$srcf\.(\w+)$/) {   if ($filename=~/\Q$srcf\E\.(\w+)$/) {
     my $subhost=$1;      my $subhost=$1;
     if ($subhost ne 'meta' && $subhost ne 'subscription') {      if (($subhost ne 'meta' && $subhost ne 'subscription') &&
                   ($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) {
  push(@subscribed,$subhost);   push(@subscribed,$subhost);
     }      }
  }   }
Line 257  sub get_subscribed_hosts { Line 450  sub get_subscribed_hosts {
  &Apache::lonnet::logthis("opened $target.subscription");   &Apache::lonnet::logthis("opened $target.subscription");
  while (my $subline=<$sh>) {   while (my $subline=<$sh>) {
     &Apache::lonnet::logthis("Trying $subline");      &Apache::lonnet::logthis("Trying $subline");
     if ($subline =~ /(^\w+):/) { push(@subscribed,$1); } else {      if ($subline =~ /(^\w+):/) { 
                   if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) { 
                      push(@subscribed,$1);
           }
               } else {
  &Apache::lonnet::logthis("No Match for $subline");   &Apache::lonnet::logthis("No Match for $subline");
     }      }
  }   }
     } else {      } else {
  &Apache::lonnet::logthis("Un able to open $target.subscription");   &Apache::lonnet::logthis("Unable to open $target.subscription");
     }      }
     &Apache::lonnet::logthis("Got list of ".join(':',@subscribed));  
     return @subscribed;      return @subscribed;
 }  }
   
   
   #########################################
   #########################################
   
   =pod
   
   =item B<get_max_ids_indices>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
 sub get_max_ids_indices {  sub get_max_ids_indices {
     my ($content)=@_;      my ($content)=@_;
     my $maxindex=10;      my $maxindex=10;
     my $maxid=10;      my $maxid=10;
     my $needsfixup=0;      my $needsfixup=0;
       my $duplicateids=0;
   
       my %allids;
       my %duplicatedids;
   
     my $parser=HTML::LCParser->new($content);      my $parser=HTML::LCParser->new($content);
     my $token;      my $token;
Line 284  sub get_max_ids_indices { Line 497  sub get_max_ids_indices {
  if ($counter eq 'id') {   if ($counter eq 'id') {
     if (defined($token->[2]->{'id'})) {      if (defined($token->[2]->{'id'})) {
  $maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;   $maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
    if (exists($allids{$token->[2]->{'id'}})) {
       $duplicateids=1;
       $duplicatedids{$token->[2]->{'id'}}=1;
    } else {
       $allids{$token->[2]->{'id'}}=1;
    }
     } else {      } else {
  $needsfixup=1;   $needsfixup=1;
     }      }
Line 297  sub get_max_ids_indices { Line 516  sub get_max_ids_indices {
     }      }
  }   }
     }      }
     return ($needsfixup,$maxid,$maxindex);      return ($needsfixup,$maxid,$maxindex,$duplicateids,
       (keys(%duplicatedids)));
 }  }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<get_all_text_unbalanced>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
 sub get_all_text_unbalanced {  sub get_all_text_unbalanced {
     #there is a copy of this in lonxml.pm      #there is a copy of this in lonxml.pm
     my($tag,$pars)= @_;      my($tag,$pars)= @_;
Line 316  sub get_all_text_unbalanced { Line 549  sub get_all_text_unbalanced {
  } elsif ($token->[0] eq 'E')  {   } elsif ($token->[0] eq 'E')  {
     $result.=$token->[2];      $result.=$token->[2];
  }   }
  if ($result =~ /(.*)$tag(.*)/) {   if ($result =~ /(.*)\Q$tag\E(.*)/s) {
     #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2);      #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2);
     #&Apache::lonnet::logthis('Result is :'.$1);      #&Apache::lonnet::logthis('Result is :'.$1);
     $result=$1;      $result=$1;
Line 329  sub get_all_text_unbalanced { Line 562  sub get_all_text_unbalanced {
     return $result      return $result
 }  }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<fix_ids_and_indices>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
 #Arguably this should all be done as a lonnet::ssi instead  #Arguably this should all be done as a lonnet::ssi instead
 sub fix_ids_and_indices {  sub fix_ids_and_indices {
     my ($logfile,$source,$target)=@_;      my ($logfile,$source,$target)=@_;
Line 340  sub fix_ids_and_indices { Line 586  sub fix_ids_and_indices {
  $content=join('',<$org>);   $content=join('',<$org>);
     }      }
   
     my ($needsfixup,$maxid,$maxindex)=&get_max_ids_indices(\$content);      my ($needsfixup,$maxid,$maxindex,$duplicateids,@duplicatedids)=
    &get_max_ids_indices(\$content);
   
       print $logfile ("Got $needsfixup,$maxid,$maxindex,$duplicateids--".
      join(', ',@duplicatedids));
       if ($duplicateids) {
    print $logfile "Duplicate ID(s) exist, ".join(', ',@duplicatedids)."\n";
    my $outstring='<font color="red">Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are: '.join(', ',@duplicatedids).'</font>';
    return ($outstring,1);
       }
     if ($needsfixup) {      if ($needsfixup) {
  print $logfile "Needs ID and/or index fixup\n".   print $logfile "Needs ID and/or index fixup\n".
     "Max ID   : $maxid (min 10)\n".      "Max ID   : $maxid (min 10)\n".
Line 465  sub fix_ids_and_indices { Line 719  sub fix_ids_and_indices {
  print $logfile "Does not need ID and/or index fixup\n";   print $logfile "Does not need ID and/or index fixup\n";
     }      }
   
     return ($outstring,%allow);      return ($outstring,0,%allow);
 }  }
   
 #########################################  #########################################
Line 473  sub fix_ids_and_indices { Line 727  sub fix_ids_and_indices {
   
 =pod  =pod
   
 =item store_metadata  =item B<store_metadata>
   
 Store the metadata in the metadata table in the loncapa database.  Store the metadata in the metadata table in the loncapa database.
 Uses lonmysql to access the database.  Uses lonmysql to access the database.
Line 524  sub store_metadata { Line 778  sub store_metadata {
     return (undef,$status);      return (undef,$status);
 }  }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<publish>
   
   This is the workhorse function of this module.  This subroutine generates
   backup copies, performs any automatic processing (prior to publication,
   especially for rat and ssi files),
   
   Returns a 2 element array, the first is the string to be shown to the
   user, the second is an error code, either 1 (an error occured) or 0
   (no error occurred)
   
   I<Additional documentation needed.>
   
   =cut
   
   #########################################
   #########################################
 sub publish {  sub publish {
   
     my ($source,$target,$style)=@_;      my ($source,$target,$style,$batch)=@_;
     my $logfile;      my $logfile;
     my $scrout='';      my $scrout='';
     my $allmeta='';      my $allmeta='';
Line 534  sub publish { Line 809  sub publish {
     my %allow=();      my %allow=();
   
     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {      unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
  return    return ('<font color="red">No write permission to user directory, FAIL</font>',1);
          '<font color=red>No write permission to user directory, FAIL</font>';  
     }      }
     print $logfile       print $logfile 
 "\n\n================= Publish ".localtime()." Phase One  ================\n";  "\n\n================= Publish ".localtime()." Phase One  ================\n";
   
     if (($style eq 'ssi') || ($style eq 'rat')) {      if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) {
 # ------------------------------------------------------- This needs processing  # ------------------------------------------------------- This needs processing
   
 # ----------------------------------------------------------------- Backup Copy  # ----------------------------------------------------------------- Backup Copy
Line 549  sub publish { Line 823  sub publish {
     print $logfile "Copied original file to ".$copyfile."\n";      print $logfile "Copied original file to ".$copyfile."\n";
         } else {          } else {
     print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";      print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";
           return "<font color=red>Failed to write backup copy, $!,FAIL</font>";      return ("<font color=\"red\">Failed to write backup copy, $!,FAIL</font>",1);
         }          }
 # ------------------------------------------------------------- IDs and indices  # ------------------------------------------------------------- IDs and indices
   
  my $outstring;   my ($outstring,$error);
  ($outstring,%allow)=&fix_ids_and_indices($logfile,$source,$target);   ($outstring,$error,%allow)=&fix_ids_and_indices($logfile,$source,
    $target);
    if ($error) { return ($outstring,$error); }
 # ------------------------------------------------------------ Construct Allows  # ------------------------------------------------------------ Construct Allows
           
  $scrout.='<h3>Dependencies</h3>';   $scrout.='<h3>Dependencies</h3>';
Line 565  sub publish { Line 841  sub publish {
            unless ($style eq 'rat') {              unless ($style eq 'rat') { 
               $allowstr.="\n".'<allow src="'.$thisdep.'" />';                $allowstr.="\n".'<allow src="'.$thisdep.'" />';
    }     }
            $scrout.='<br>';             $scrout.='<br />';
            unless ($thisdep=~/\*/) {             unless ($thisdep=~/\*/) {
        $scrout.='<a href="'.$thisdep.'">';         $scrout.='<a href="'.$thisdep.'">';
            }             }
Line 575  sub publish { Line 851  sub publish {
                if (                 if (
        &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'.         &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
                                             $thisdep.'.meta') eq '-1') {                                              $thisdep.'.meta') eq '-1') {
    $scrout.=     $scrout.= ' - <font color="red">Currently not available'.
                            ' - <font color=red>Currently not available</font>';         '</font>';
                } else {                 } else {
                    my %temphash=(&Apache::lonnet::declutter($target).'___'.                     my %temphash=(&Apache::lonnet::declutter($target).'___'.
                              &Apache::lonnet::declutter($thisdep).'___usage'                               &Apache::lonnet::declutter($thisdep).'___usage'
                                  => time);                                   => time);
                    $thisdep=~/^\/res\/(\w+)\/(\w+)\//;                     $thisdep=~/^\/res\/(\w+)\/(\w+)\//;
                    if ((defined($1)) && (defined($2))) {                     if ((defined($1)) && (defined($2))) {
                       &Apache::lonnet::put('resevaldata',\%temphash,$1,$2);                        &Apache::lonnet::put('nohist_resevaldata',\%temphash,
      $1,$2);
    }     }
        }         }
            }             }
Line 592  sub publish { Line 869  sub publish {
   
  #Encode any High ASCII characters   #Encode any High ASCII characters
  $outstring=&HTML::Entities::encode($outstring,"\200-\377");   $outstring=&HTML::Entities::encode($outstring,"\200-\377");
 # ------------------------------------------------------------- Write modified  # ------------------------------------------------------------- Write modified.
   
         {          {
           my $org;            my $org;
           unless ($org=Apache::File->new('>'.$source)) {            unless ($org=Apache::File->new('>'.$source)) {
              print $logfile "No write permit to $source\n";               print $logfile "No write permit to $source\n";
              return                return ('<font color="red">No write permission to '.$source.
               "<font color=red>No write permission to $source, FAIL</font>";       ', FAIL</font>',1);
   }    }
           print $org $outstring;            print($org $outstring);
         }          }
   $content=$outstring;    $content=$outstring;
   
     }      }
 # --------------------------------------------- Initial step done, now metadata  # -------------------------------------------- Initial step done, now metadata.
   
 # ---------------------------------------- Storage for metadata keys and fields  # --------------------------------------- Storage for metadata keys and fields.
   
      %metadatafields=();       %metadatafields=();
      %metadatakeys=();       %metadatakeys=();
             
      my %oldparmstores=();       my %oldparmstores=();
             
            unless ($batch) {
      $scrout.='<h3>Metadata Information ' .       $scrout.='<h3>Metadata Information ' .
        Apache::loncommon::help_open_topic("Metadata_Description")         Apache::loncommon::help_open_topic("Metadata_Description")
        . '</h3>';         . '</h3>';
       }
   
 # ------------------------------------------------ First, check out environment  # ------------------------------------------------ First, check out environment
      unless (-e $source.'.meta') {       unless (-e $source.'.meta') {
Line 668  sub publish { Line 946  sub publish {
     }      }
   
 # -------------------------------------------------- Parse content for metadata  # -------------------------------------------------- Parse content for metadata
     if ($style eq 'ssi') {      if (($style eq 'ssi') || ($style eq 'prv')) {
         my $oldenv=$ENV{'request.uri'};          my $oldenv=$ENV{'request.uri'};
   
         $ENV{'request.uri'}=$target;          $ENV{'request.uri'}=$target;
Line 679  sub publish { Line 957  sub publish {
     }      }
 # ---------------- Find and document discrepancies in the parameters and stores  # ---------------- Find and document discrepancies in the parameters and stores
   
         my $chparms='';      my $chparms='';
         foreach (sort keys %metadatafields) {      foreach (sort keys %metadatafields) {
     if (($_=~/^parameter/) || ($_=~/^stores/)) {   if (($_=~/^parameter/) || ($_=~/^stores/)) {
                 unless ($_=~/\.\w+$/) {       unless ($_=~/\.\w+$/) { 
                    unless ($oldparmstores{$_}) {   unless ($oldparmstores{$_}) {
       print $logfile 'New: '.$_."\n";      print $logfile 'New: '.$_."\n";
                       $chparms.=$_.' ';      $chparms.=$_.' ';
                    }   }
         }      }
             }   }
         }      }
         if ($chparms) {      if ($chparms) {
     $scrout.='<p><b>New parameters or stored values:</b> '.   $scrout.='<p><b>New parameters or stored values:</b> '.$chparms.'</p>';
                      $chparms;      }
         }  
   
         $chparms='';      $chparms='';
         foreach (sort keys %oldparmstores) {      foreach (sort keys %oldparmstores) {
     if (($_=~/^parameter/) || ($_=~/^stores/)) {   if (($_=~/^parameter/) || ($_=~/^stores/)) {
                 unless (($metadatafields{$_.'.name'}) ||      unless (($metadatafields{$_.'.name'}) ||
                         ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) {      ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) {
     print $logfile 'Obsolete: '.$_."\n";   print $logfile 'Obsolete: '.$_."\n";
                     $chparms.=$_.' ';   $chparms.=$_.' ';
                 }      }
             }   }
         }      }
         if ($chparms) {      if ($chparms) {
     $scrout.='<p><b>Obsolete parameters or stored values:</b> '.   $scrout.='<p><b>Obsolete parameters or stored values:</b> '.
                      $chparms;      $chparms.'</p>';
         }      }
   
 # ------------------------------------------------------- Now have all metadata  # ------------------------------------------------------- Now have all metadata
   
       my %keywords=();
           
       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;
   
    foreach ($textonly=~m/(\w+)/g) {
       unless ($nokey{$_}) {
    $keywords{$_}=1;
       } 
    }
       }
   
               
       foreach (split(/\W+/,$metadatafields{'keywords'})) {
    $keywords{$_}=1;
       }
   # --------------------------------------------------- Now we also have keywords
   # =============================================================================
   # INTERACTIVE MODE
   #
       unless ($batch) {
         $scrout.=          $scrout.=
      '<form name="pubform" action="/adm/publish" method="post">'.      '<form name="pubform" action="/adm/publish" method="post">'.
        '<p><input type="submit" value="Finalize Publication" /></p>'.              '<p><input type="submit" value="Finalize Publication" /></p>'.
           &hiddenfield('phase','two').              &hiddenfield('phase','two').
           &hiddenfield('filename',$ENV{'form.filename'}).              &hiddenfield('filename',$ENV{'form.filename'}).
   &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).      &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).
           &hiddenfield('dependencies',join(',',keys %allow)).              &hiddenfield('dependencies',join(',',keys %allow)).
           &textfield('Title','title',$metadatafields{'title'}).              &textfield('Title','title',$metadatafields{'title'}).
           &textfield('Author(s)','author',$metadatafields{'author'}).              &textfield('Author(s)','author',$metadatafields{'author'}).
   &textfield('Subject','subject',$metadatafields{'subject'});      &textfield('Subject','subject',$metadatafields{'subject'});
   
 # --------------------------------------------------- Scan content for keywords  # --------------------------------------------------- Scan content for keywords
   
         my $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords");          my $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords");
  my $keywordout=<<"END";   my $keywordout=<<"END";
 <script>  <script>
 function checkAll(field)  function checkAll(field) {
 {  
     for (i = 0; i < field.length; i++)      for (i = 0; i < field.length; i++)
         field[i].checked = true ;          field[i].checked = true ;
 }  }
   
 function uncheckAll(field)  function uncheckAll(field) {
 {  
     for (i = 0; i < field.length; i++)      for (i = 0; i < field.length; i++)
         field[i].checked = false ;          field[i].checked = false ;
 }  }
 </script>  </script>
 <p><b>Keywords: $keywords_help</b>   <p><b>Keywords: $keywords_help</b> 
 <input type="button" value="check all" onclick="javascript:checkAll(document.pubform.keywords)">   <input type="button" value="check all" onclick="javascript:checkAll(document.pubform.keywords)" /> 
 <input type="button" value="uncheck all" onclick="javascript:uncheckAll(document.pubform.keywords)">   <input type="button" value="uncheck all" onclick="javascript:uncheckAll(document.pubform.keywords)" /> 
   </p>
 <br />  <br />
 END  END
         $keywordout.='<table border=2><tr>';   $keywordout.='<table border="2"><tr>';
         my $colcount=0;   my $colcount=0;
         my %keywords=();  
           
  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;  
   
             foreach ($textonly=~m/(\w+)/g) {  
  unless ($nokey{$_}) {  
                    $keywords{$_}=1;  
                 }   
             }  
         }  
   
                foreach (sort keys %keywords) {
             foreach (split(/\W+/,$metadatafields{'keywords'})) {      $keywordout.='<td><input type="checkbox" name="keywords" value="'.$_.'"';
  $keywords{$_}=1;      if ($metadatafields{'keywords'}) {
             }   if ($metadatafields{'keywords'}=~/$_/) {
       $keywordout.=' checked="on"';
    }
       } elsif (&Apache::loncommon::keyword($_)) {
    $keywordout.=' checked="on"';
       }
       $keywordout.=' />'.$_.'</td>';
       if ($colcount>10) {
    $keywordout.="</tr><tr>\n";
    $colcount=0;
       }
       $colcount++;
    }
   
             foreach (sort keys %keywords) {  
                 $keywordout.='<td><input type=checkbox name="keywords" value="'.$_.'"';  
                 if ($metadatafields{'keywords'}) {  
                    if ($metadatafields{'keywords'}=~/$_/) {   
                       $keywordout.=' checked';   
                    }  
         } elsif (&Apache::loncommon::keyword($_)) {  
             $keywordout.=' checked';  
                 }   
                 $keywordout.='>'.$_.'</td>';  
                 if ($colcount>10) {  
     $keywordout.="</tr><tr>\n";  
                     $colcount=0;  
                 }  
                 $colcount++;  
             }  
           
  $keywordout.='</tr></table>';   $keywordout.='</tr></table>';
   
         $scrout.=$keywordout;   $scrout.=$keywordout;
   
         $scrout.=&textfield('Additional Keywords','addkey','');   $scrout.=&textfield('Additional Keywords','addkey','');
   
         $scrout.=&textfield('Notes','notes',$metadatafields{'notes'});   $scrout.=&textfield('Notes','notes',$metadatafields{'notes'});
   
         $scrout.=   $scrout.=
              '<p><b>Abstract:</b><br><textarea cols=80 rows=5 name=abstract>'.      '<p><b>Abstract:</b><br /><textarea cols="80" rows="5" name="abstract">'.
               $metadatafields{'abstract'}.'</textarea>';      $metadatafields{'abstract'}.'</textarea></p>';
   
  $source=~/\.(\w+)$/;   $source=~/\.(\w+)$/;
   
  $scrout.=&hiddenfield('mime',$1);   $scrout.=&hiddenfield('mime',$1);
   
         $scrout.=&selectbox('Language','language',   $scrout.=&selectbox('Language','language',
                             $metadatafields{'language'},      $metadatafields{'language'},
     \&Apache::loncommon::languagedescription,      \&Apache::loncommon::languagedescription,
     (&Apache::loncommon::languageids),      (&Apache::loncommon::languageids),
      );     );
   
         unless ($metadatafields{'creationdate'}) {   unless ($metadatafields{'creationdate'}) {
     $metadatafields{'creationdate'}=time;      $metadatafields{'creationdate'}=time;
         }   }
         $scrout.=&hiddenfield('creationdate',$metadatafields{'creationdate'});   $scrout.=&hiddenfield('creationdate',
         &Apache::loncommon::unsqltime($metadatafields{'creationdate'}));
   
    $scrout.=&hiddenfield('lastrevisiondate',time);
   
         $scrout.=&hiddenfield('lastrevisiondate',time);  
   
      
  $scrout.=&textfield('Publisher/Owner','owner',   $scrout.=&textfield('Publisher/Owner','owner',
                             $metadatafields{'owner'});      $metadatafields{'owner'});
 # --------------------------------------------------- Correct copyright for rat          
   
     if ($style eq 'rat') {  # -------------------------------------------------- Correct copyright for rat.
  if ($metadatafields{'copyright'} eq 'public') {    unless ($style eq 'prv') {
     delete $metadatafields{'copyright'};      if ($style eq 'rat') {
    if ($metadatafields{'copyright'} eq 'public') { 
       delete $metadatafields{'copyright'};
    }
    $scrout.=&selectbox('Copyright/Distribution','copyright',
       $metadatafields{'copyright'},
       \&Apache::loncommon::copyrightdescription,
       (grep !/^public$/,(&Apache::loncommon::copyrightids)));
       } else {
    $scrout.=&selectbox('Copyright/Distribution','copyright',
       $metadatafields{'copyright'},
       \&Apache::loncommon::copyrightdescription,
       (&Apache::loncommon::copyrightids));
       }
       
       my $copyright_help =
    Apache::loncommon::help_open_topic('Publishing_Copyright');
       $scrout =~ s/DISTRIBUTION:/'DISTRIBUTION: ' . $copyright_help/ge;
       $scrout.=&textfield('Custom Distribution File','customdistributionfile',
    $metadatafields{'customdistributionfile'}).
       $copyright_help;
    } else {
       $scrout.=&hiddenfield('copyright','private');
  }   }
         $scrout.=&selectbox('Copyright/Distribution','copyright',   return ($scrout.'<p><input type="submit" value="Finalize Publication" /></p></form>',0);
                             $metadatafields{'copyright'},  # =============================================================================
     \&Apache::loncommon::copyrightdescription,  # BATCH MODE
      (grep !/^public$/,(&Apache::loncommon::copyrightids)));  #
     }      } else {
     else {  # Transfer metadata directly to environment for stage 2
         $scrout.=&selectbox('Copyright/Distribution','copyright',   foreach (keys %metadatafields) {
                             $metadatafields{'copyright'},      $ENV{'form.'.$_}=$metadatafields{$_};
     \&Apache::loncommon::copyrightdescription,   }
      (&Apache::loncommon::copyrightids));   $ENV{'form.addkey'}='';
    $ENV{'form.keywords'}='';
    foreach (keys %keywords) {
       if ($metadatafields{'keywords'}) {
    if ($metadatafields{'keywords'}=~/$_/) { 
       $ENV{'form.keywords'}.=$_.','; 
    }
       } elsif (&Apache::loncommon::keyword($_)) {
    $ENV{'form.keywords'}.=$_.',';
       }
    }
    $ENV{'form.keywords'}=~s/\,$//;
    unless ($ENV{'form.creationdate'}) { $ENV{'form.creationdate'}=time; }
    $ENV{'form.lastrevisiondate'}=time;
    if ((($style eq 'rat') && ($ENV{'form.copyright'} eq 'public')) ||
       (!$ENV{'form.copyright'})) { 
       $ENV{'form.copyright'}='default';
    }
    $ENV{'form.allmeta'}=&Apache::lonnet::escape($allmeta);
    return ($scrout,0);
     }      }
   
     my $copyright_help = Apache::loncommon::help_open_topic("Publishing_Copyright");  
     $scrout =~ s/DISTRIBUTION:/'DISTRIBUTION: ' . $copyright_help/ge;  
     return $scrout.  
       '<p><input type="submit" value="Finalize Publication" /></p></form>';  
 }  }
   
 # -------------------------------------------------------- Publication Step Two  #########################################
   #########################################
   
   =pod 
   
   =item B<phasetwo>
   
   Render second interface showing status of publication steps.
   This is publication step two.
   
   Parameters:
   
   =over 4
   
   =item I<$source>
   
   =item I<$target>
   
   =item I<$style>
   
   =item I<$distarget>
   
   =back
   
   Returns:
   
   =over 4
   
   =item Scalar string
   
   String contains status (errors and warnings) and information associated with
   the server's attempts at publication.     
   
   =cut
   
   #'stupid emacs
   #########################################
   #########################################
 sub phasetwo {  sub phasetwo {
   
     my ($source,$target,$style,$distarget)=@_;      my ($r,$source,$target,$style,$distarget,$batch)=@_;
       $source=~s/\/+/\//g;
       $target=~s/\/+/\//g;
   
       if ($target=~/\_\_\_/) {
    $r->print(
    '<font color="red">Unsupported character combination "<tt>___</tt>" in filename, FAIL</font>');
           return 0;
       }
       $distarget=~s/\/+/\//g;
     my $logfile;      my $logfile;
     my $scrout='';  
     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {      unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
  return    $r->print(
          '<font color=red>No write permission to user directory, FAIL</font>';          '<font color="red">No write permission to user directory, FAIL</font>');
           return 0;
     }      }
     print $logfile       print $logfile 
 "\n================= Publish ".localtime()." Phase Two  ================\n";          "\n================= Publish ".localtime()." Phase Two  ================\n";
       
      %metadatafields=();      %metadatafields=();
      %metadatakeys=();      %metadatakeys=();
       
      &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'}));      &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'}));
       
      $metadatafields{'title'}=$ENV{'form.title'};      $metadatafields{'title'}=$ENV{'form.title'};
      $metadatafields{'author'}=$ENV{'form.author'};      $metadatafields{'author'}=$ENV{'form.author'};
      $metadatafields{'subject'}=$ENV{'form.subject'};      $metadatafields{'subject'}=$ENV{'form.subject'};
      $metadatafields{'notes'}=$ENV{'form.notes'};      $metadatafields{'notes'}=$ENV{'form.notes'};
      $metadatafields{'abstract'}=$ENV{'form.abstract'};      $metadatafields{'abstract'}=$ENV{'form.abstract'};
      $metadatafields{'mime'}=$ENV{'form.mime'};      $metadatafields{'mime'}=$ENV{'form.mime'};
      $metadatafields{'language'}=$ENV{'form.language'};      $metadatafields{'language'}=$ENV{'form.language'};
      $metadatafields{'creationdate'}=$ENV{'form.creationdate'};      $metadatafields{'creationdate'}=$ENV{'form.creationdate'};
      $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'};      $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'};
      $metadatafields{'owner'}=$ENV{'form.owner'};      $metadatafields{'owner'}=$ENV{'form.owner'};
      $metadatafields{'copyright'}=$ENV{'form.copyright'};      $metadatafields{'copyright'}=$ENV{'form.copyright'};
      $metadatafields{'dependencies'}=$ENV{'form.dependencies'};      $metadatafields{'customdistributionfile'}=
                                    $ENV{'form.customdistributionfile'};
      my $allkeywords=$ENV{'form.addkey'};      $metadatafields{'dependencies'}=$ENV{'form.dependencies'};
      if (exists($ENV{'form.keywords'}) && (ref($ENV{'form.keywords'}))) {      
          my @Keywords = @{$ENV{'form.keywords'}};      my $allkeywords=$ENV{'form.addkey'};
          foreach (@Keywords) {      if (exists($ENV{'form.keywords'})) {
              $allkeywords.=','.$_;          if (ref($ENV{'form.keywords'})) {
          }              $allkeywords .= ','.join(',',@{$ENV{'form.keywords'}});
      }          } else {
      $allkeywords=~s/\W+/\,/;              $allkeywords .= ','.$ENV{'form.keywords'};
      $allkeywords=~s/^\,//;          }
      $metadatafields{'keywords'}=$allkeywords;      }
        $allkeywords=~s/\W+/\,/;
      {      $allkeywords=~s/^\,//;
        print $logfile "\nWrite metadata file for ".$source;      $metadatafields{'keywords'}=$allkeywords;
        my $mfh;      
        unless ($mfh=Apache::File->new('>'.$source.'.meta')) {      {
  return           print $logfile "\nWrite metadata file for ".$source;
          '<font color=red>Could not write metadata, FAIL</font>';          my $mfh;
        }          unless ($mfh=Apache::File->new('>'.$source.'.meta')) {
        foreach (sort keys %metadatafields) {              return 
  unless ($_=~/\./) {                  '<font color="red">Could not write metadata, FAIL</font>';
            my $unikey=$_;          }
            $unikey=~/^([A-Za-z]+)/;          foreach (sort keys %metadatafields) {
            my $tag=$1;              unless ($_=~/\./) {
            $tag=~tr/A-Z/a-z/;                  my $unikey=$_;
            print $mfh "\n\<$tag";                  $unikey=~/^([A-Za-z]+)/;
            foreach (split(/\,/,$metadatakeys{$unikey})) {                  my $tag=$1;
                my $value=$metadatafields{$unikey.'.'.$_};                  $tag=~tr/A-Z/a-z/;
                $value=~s/\"/\'\'/g;                  print $mfh "\n\<$tag";
                print $mfh ' '.$_.'="'.$value.'"';                  foreach (split(/\,/,$metadatakeys{$unikey})) {
            }                      my $value=$metadatafields{$unikey.'.'.$_};
    print $mfh '>'.                      $value=~s/\"/\'\'/g;
      &HTML::Entities::encode($metadatafields{$unikey})                      print $mfh ' '.$_.'="'.$value.'"';
        .'</'.$tag.'>';                  }
          }                  print $mfh '>'.
        }                      &HTML::Entities::encode($metadatafields{$unikey})
        $scrout.='<p>Wrote Metadata';                          .'</'.$tag.'>';
        print $logfile "\nWrote metadata";              }
      }          }
           $r->print('<p>Wrote Metadata</p>');
           print $logfile "\nWrote metadata";
       }
       
 # -------------------------------- Synchronize entry with SQL metadata database  # -------------------------------- Synchronize entry with SQL metadata database
     my $warning;  
     $metadatafields{'url'} = $distarget;      $metadatafields{'url'} = $distarget;
     $metadatafields{'version'} = 'current';      $metadatafields{'version'} = 'current';
     unless ($metadatafields{'copyright'} eq 'priv') {      unless ($metadatafields{'copyright'} eq 'priv') {
         my ($error,$success) = &store_metadata(\%metadatafields);          my ($error,$success) = &store_metadata(\%metadatafields);
         if (! $success) {          if ($success) {
             $scrout.='<p>Synchronized SQL metadata database';              $r->print('<p>Synchronized SQL metadata database</p>');
             print $logfile "\nSynchronized SQL metadata database";              print $logfile "\nSynchronized SQL metadata database";
         } else {          } else {
             $warning.=$error;              $r->print($error);
             print $logfile "\n".$error;              print $logfile "\n".$error;
         }          }
     } else {      } else {
         $scrout.='<p>Private Publication - did not synchronize database';          $r->print('<p>Private Publication - did not synchronize database</p>');
         print $logfile "\nPrivate: Did not synchronize data into ".          print $logfile "\nPrivate: Did not synchronize data into ".
             "SQL metadata database";              "SQL metadata database";
     }      }
 # ----------------------------------------------------------- Copy old versions  # ----------------------------------------------------------- Copy old versions
         
 if (-e $target) {      if (-e $target) {
     my $filename;          my $filename;
     my $maxversion=0;          my $maxversion=0;
     $target=~/(.*)\/([^\/]+)\.(\w+)$/;          $target=~/(.*)\/([^\/]+)\.(\w+)$/;
     my $srcf=$2;          my $srcf=$2;
     my $srct=$3;          my $srct=$3;
     my $srcd=$1;          my $srcd=$1;
     unless ($srcd=~/^\/home\/httpd\/html\/res/) {          unless ($srcd=~/^\/home\/httpd\/html\/res/) {
  print $logfile "\nPANIC: Target dir is ".$srcd;              print $logfile "\nPANIC: Target dir is ".$srcd;
         return "<font color=red>Invalid target directory, FAIL</font>";              return "<font color=\"red\">Invalid target directory, FAIL</font>";
     }          }
     opendir(DIR,$srcd);          opendir(DIR,$srcd);
     while ($filename=readdir(DIR)) {          while ($filename=readdir(DIR)) {
        if ($filename=~/$srcf\.(\d+)\.$srct$/) {              if (-l $srcd.'/'.$filename) {
    $maxversion=($1>$maxversion)?$1:$maxversion;                  unlink($srcd.'/'.$filename);
        }                  unlink($srcd.'/'.$filename.'.meta');
     }              } else {
     closedir(DIR);                  if ($filename=~/\Q$srcf\E\.(\d+)\.\Q$srct\E$/) {
     $maxversion++;                      $maxversion=($1>$maxversion)?$1:$maxversion;
     $scrout.='<p>Creating old version '.$maxversion;                  }
     print $logfile "\nCreating old version ".$maxversion;              }
           }
     my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct;          closedir(DIR);
           $maxversion++;
           $r->print('<p>Creating old version '.$maxversion.'</p>');
           print $logfile "\nCreating old version ".$maxversion;
           
           my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct;
           
         if (copy($target,$copyfile)) {          if (copy($target,$copyfile)) {
     print $logfile "Copied old target to ".$copyfile."\n";      print $logfile "Copied old target to ".$copyfile."\n";
             $scrout.='<p>Copied old target file';              $r->print('<p>Copied old target file</p>');
         } else {          } else {
     print $logfile "Unable to write ".$copyfile.':'.$!."\n";      print $logfile "Unable to write ".$copyfile.':'.$!."\n";
            return "<font color=red>Failed to copy old target, $!, FAIL</font>";              return "<font color=\"red\">Failed to copy old target, $!, FAIL</font>";
         }          }
           
 # --------------------------------------------------------------- Copy Metadata  # --------------------------------------------------------------- Copy Metadata
   
  $copyfile=$copyfile.'.meta';   $copyfile=$copyfile.'.meta';
           
         if (copy($target.'.meta',$copyfile)) {          if (copy($target.'.meta',$copyfile)) {
     print $logfile "Copied old target metadata to ".$copyfile."\n";      print $logfile "Copied old target metadata to ".$copyfile."\n";
             $scrout.='<p>Copied old metadata';              $r->print('<p>Copied old metadata</p>')
         } else {          } else {
     print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n";      print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n";
             if (-e $target.'.meta') {              if (-e $target.'.meta') {
                return                   return 
        "<font color=red>Failed to write old metadata copy, $!, FAIL</font>";                      "<font color=\"red\">Failed to write old metadata copy, $!, FAIL</font>";
     }      }
         }          }
           
           
 } else {      } else {
     $scrout.='<p>Initial version';          $r->print('<p>Initial version</p>');
     print $logfile "\nInitial version";          print $logfile "\nInitial version";
 }      }
   
 # ---------------------------------------------------------------- Write Source  # ---------------------------------------------------------------- Write Source
  my $copyfile=$target;      my $copyfile=$target;
       
            my @parts=split(/\//,$copyfile);      my @parts=split(/\//,$copyfile);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";      my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
       
            my $count;      my $count;
            for ($count=5;$count<$#parts;$count++) {      for ($count=5;$count<$#parts;$count++) {
                $path.="/$parts[$count]";          $path.="/$parts[$count]";
                if ((-e $path)!=1) {          if ((-e $path)!=1) {
                    print $logfile "\nCreating directory ".$path;              print $logfile "\nCreating directory ".$path;
                    $scrout.='<p>Created directory '.$parts[$count];              $r->print('<p>Created directory '.$parts[$count].'</p>');
    mkdir($path,0777);              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>";  
         }          }
       }
       
       if (copy($source,$copyfile)) {
           print $logfile "\nCopied original source to ".$copyfile."\n";
           $r->print('<p>Copied source file</p>');
       } else {
           print $logfile "\nUnable to write ".$copyfile.':'.$!."\n";
           return "<font color=\"red\">Failed to copy source, $!, FAIL</font>";
       }
       
 # --------------------------------------------------------------- Copy Metadata  # --------------------------------------------------------------- Copy Metadata
   
         $copyfile=$copyfile.'.meta';      $copyfile=$copyfile.'.meta';
       
         if (copy($source.'.meta',$copyfile)) {      if (copy($source.'.meta',$copyfile)) {
     print $logfile "Copied original metadata to ".$copyfile."\n";          print $logfile "\nCopied original metadata to ".$copyfile."\n";
             $scrout.='<p>Copied metadata';          $r->print('<p>Copied metadata</p>');
         } else {      } else {
     print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n";          print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n";
             return           return 
           "<font color=red>Failed to write metadata copy, $!, FAIL</font>";              "<font color=\"red\">Failed to write metadata copy, $!, FAIL</font>";
         }      }
       $r->rflush;
 # --------------------------------------------------- Send update notifications  # --------------------------------------------------- Send update notifications
   
     my @subscribed=&get_subscribed_hosts($target);      my @subscribed=&get_subscribed_hosts($target);
     foreach my $subhost (@subscribed) {      foreach my $subhost (@subscribed) {
  $scrout.='<p>Notifying host '.$subhost.':';   $r->print('<p>Notifying host '.$subhost.':');$r->rflush;
  print $logfile "\nNotifying host ".$subhost.':';   print $logfile "\nNotifying host ".$subhost.':';
  my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);   my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);
  $scrout.=$reply;   $r->print($reply.'</p><br />');$r->rflush;
  print $logfile $reply;   print $logfile $reply;
     }      }
       
 # ---------------------------------------- Send update notifications, meta only  # ---------------------------------------- Send update notifications, meta only
   
     my @subscribedmeta=&get_subscribed_hosts("$target.meta");      my @subscribedmeta=&get_subscribed_hosts("$target.meta");
     foreach my $subhost (@subscribedmeta) {      foreach my $subhost (@subscribedmeta) {
  $scrout.='<p>Notifying host for metadata only '.$subhost.':';   $r->print('<p>Notifying host for metadata only '.$subhost.':');$r->rflush;
  print $logfile "\nNotifying host for metadata only ".$subhost.':';   print $logfile "\nNotifying host for metadata only ".$subhost.':';
  my $reply=&Apache::lonnet::critical('update:'.$target.'.meta',   my $reply=&Apache::lonnet::critical('update:'.$target.'.meta',
     $subhost);      $subhost);
  $scrout.=$reply;   $r->print($reply.'</p><br />');$r->rflush;
    print $logfile $reply;
       }
       
   # --------------------------------------------------- Notify subscribed courses
       my %courses=&coursedependencies($target);
       my $now=time;
       foreach (keys %courses) {
    $r->print('<p>Notifying course '.$_.':');$r->rflush;
    print $logfile "\nNotifying host ".$_.':';
           my ($cdom,$cname)=split(/\_/,$_);
    my $reply=&Apache::lonnet::cput
                     ('versionupdate',{$target => $now},$cdom,$cname);
    $r->print($reply.'</p><br />');$r->rflush;
  print $logfile $reply;   print $logfile $reply;
     }      }
   
 # ------------------------------------------------ Provide link to new resource  # ------------------------------------------------ Provide link to new resource
       unless ($batch) {
           my $thisdistarget=$target;
           $thisdistarget=~s/^$docroot//;
           
           my $thissrc=$source;
           $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/;
           
           my $thissrcdir=$thissrc;
           $thissrcdir=~s/\/[^\/]+$/\//;
           
           
           $r->print(
              '<hr /><a href="'.$thisdistarget.'"><font size="+2">'.
              'View Published Version</font></a>'.
              '<p><a href="'.$thissrc.'"><font size=+2>Back to Source</font></a></p>'.
              '<p><a href="'.$thissrcdir.
                      '"><font size="+2">Back to Source Directory</font></a></p>');
       }
   }
   
   #########################################
   
     my $thisdistarget=$target;  sub batchpublish {
       my ($r,$srcfile,$targetfile)=@_;
       $srcfile=~s/\/+/\//g;
       $targetfile=~s/\/+/\//g;
       my $thisdisfn=$srcfile;
       $thisdisfn=~s/\/home\/korte\/public_html\///;
       $srcfile=~s/\/+/\//g;
   
       my $docroot=$r->dir_config('lonDocRoot');
       my $thisdistarget=$targetfile;
     $thisdistarget=~s/^$docroot//;      $thisdistarget=~s/^$docroot//;
   
     my $thissrc=$source;  
     $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/;  
   
     my $thissrcdir=$thissrc;      undef %metadatafields;
     $thissrcdir=~s/\/[^\/]+$/\//;      undef %metadatakeys;
        %metadatafields=();
        %metadatakeys=();
         $srcfile=~/\.(\w+)$/;
         my $thistype=$1;
   
   
     return $warning.$scrout.        my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
       '<hr><a href="'.$thisdistarget.'"><font size=+2>View Published Version</font></a>'.       
       '<p><a href="'.$thissrc.'"><font size=+2>Back to Source</font></a>'.      $r->print('<h2>Publishing <tt>'.$thisdisfn.'</tt></h2>');
       '<p><a href="'.$thissrcdir.  
       '"><font size=+2>Back to Source Directory</font></a>';  
   
   # phase one takes
   #  my ($source,$target,$style,$batch)=@_;
       my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1);
       $r->print('<p>'.$outstring.'</p>');
   # phase two takes
   # my ($source,$target,$style,$distarget,batch)=@_;
   # $ENV{'form.allmeta'},$ENV{'form.title'},$ENV{'form.author'},...
       if (!$error) {
    $r->print('<p>');
    &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1);
    $r->print('</p>');
       }
       return '';
 }  }
   
 # ================================================================ Main Handler  #########################################
   
   sub publishdirectory {
       my ($r,$fn,$thisdisfn)=@_;
       $fn=~s/\/+/\//g;
       $thisdisfn=~s/\/+/\//g;
       my $resdir=
       $Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$cudom.'/'.$cuname.'/'.
         $thisdisfn;
         $r->print('<h1>Directory <tt>'.$thisdisfn.'</tt></h1>'.
                   'Target: <tt>'.$resdir.'</tt><br />');
   
         my $dirptr=16384; # Mask indicating a directory in stat.cmode.
   
         opendir(DIR,$fn);
         my @files=sort(readdir(DIR));
         foreach my $filename (@files) {
            my ($cdev,$cino,$cmode,$cnlink,
               $cuid,$cgid,$crdev,$csize,
               $catime,$cmtime,$cctime,
               $cblksize,$cblocks)=stat($fn.'/'.$filename);
   
            my $extension='';
            if ($filename=~/\.(\w+)$/) { $extension=$1; }
            if ($cmode&$dirptr) {
      if (($filename!~/^\./) && ($ENV{'form.pubrec'})) {
         &publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename);
      }
            } elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') &&
                     ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) {
   # find out publication status and/or exiting metadata
        my $publishthis=0;
                if (-e $resdir.'/'.$filename) {
           my ($rdev,$rino,$rmode,$rnlink,
           $ruid,$rgid,$rrdev,$rsize,
           $ratime,$rmtime,$rctime,
           $rblksize,$rblocks)=stat($resdir.'/'.$filename);
           if ($rmtime<$cmtime) {
   # previously published, modified now
       $publishthis=1;
                   }
        } else {
   # never published
    $publishthis=1;
        }
                if ($publishthis) {
                   &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename);
        } else {
                    $r->print('<br />Skipping '.$filename.'<br />');
                }
                $r->rflush();
            }
         }
         closedir(DIR);
   }
   #########################################
   
   =pod
   
   =item B<handler>
   
   A basic outline of the handler subroutine follows.
   
   =over 4
   
   =item *
   
   Get query string for limited number of parameters.
   
   =item *
   
   Check filename.
   
   =item *
   
   File is there and owned, init lookup tables.
   
   =item *
   
   Start page output.
   
   =item *
   
   Evaluate individual file, and then output information.
   
   =item *
   
   Publishing from $thisfn to $thistarget with $thisembstyle.
   
   =back
   
   =cut
   
   #########################################
   #########################################
 sub handler {  sub handler {
   my $r=shift;    my $r=shift;
   
Line 1085  sub handler { Line 1603  sub handler {
   
 # -------------------------------------------------------------- Check filename  # -------------------------------------------------------------- Check filename
   
   my $fn=$ENV{'form.filename'};    my $fn=&Apache::lonnet::unescape($ENV{'form.filename'});
   
       
   unless ($fn) {     unless ($fn) { 
Line 1140  sub handler { Line 1658  sub handler {
   
 unless ($ENV{'form.phase'} eq 'two') {  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 1164  unless ($ENV{'form.phase'} eq 'two') { Line 1682  unless ($ENV{'form.phase'} eq 'two') {
   
 }  }
   
 # ----------------------------------------------------------- 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(    $r->print(&Apache::loncommon::bodytag('Resource Publication'));
    '<body bgcolor="#FFFFFF"><img align=right src=/adm/lonIcons/lonlogos.gif>');  
   
   my $thisfn=$fn;    my $thisfn=$fn;
      
 # ------------------------------------------------------------- Individual file  
   {  
       $thisfn=~/\.(\w+)$/;  
       my $thistype=$1;  
       my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);  
   
       my $thistarget=$thisfn;    my $thistarget=$thisfn;
               
       $thistarget=~s/^\/home/$targetdir/;    $thistarget=~s/^\/home/$targetdir/;
       $thistarget=~s/\/public\_html//;    $thistarget=~s/\/public\_html//;
   
     my $thisdistarget=$thistarget;
     $thisdistarget=~s/^$docroot//;
   
     my $thisdisfn=$thisfn;
     $thisdisfn=~s/^\/home\/$cuname\/public_html\///;
   
       my $thisdistarget=$thistarget;    if ($fn=~/\/$/) {
       $thisdistarget=~s/^$docroot//;  # -------------------------------------------------------- This is a directory
         &publishdirectory($r,$fn,$thisdisfn);
   
       my $thisdisfn=$thisfn;    } else {
       $thisdisfn=~s/^\/home\/$cuname\/public_html\///;  # ---------------------- Evaluate individual file, and then output information.
         $thisfn=~/\.(\w+)$/;
         my $thistype=$1;
         my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
   
       $r->print('<h2>Publishing '.        $r->print('<h2>Publishing '.
         &Apache::loncommon::filedescription($thistype).' <tt>'.          &Apache::loncommon::filedescription($thistype).' <tt>'.
         $thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>');          '<a href="/~'.$cuname.'/'.$thisdisfn.'" target="cat">'.$thisdisfn.
           '</a></tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><br />');
         
        if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) {        if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) {
           $r->print('<h3><font color=red>Co-Author: '.$cuname.' at '.$cudom.            $r->print('<h3><font color="red">Co-Author: '.$cuname.' at '.$cudom.
                '</font></h3>');      '</font></h3>');
       }        }
   
       if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') {        if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') {
           $r->print('<br><a href="/adm/diff?filename=/~'.$cuname.'/'.            $r->print('<br /><a href="/adm/diff?filename=/~'.$cuname.'/'.
                     $thisdisfn.                      $thisdisfn.
    '&versionone=priv" target=cat>Diffs with Current Version</a><p>');     '&versiontwo=priv" target="cat">Diffs with Current Version</a><br />');
       }        }
       
 # ------------ We are publishing from $thisfn to $thistarget with $thisembstyle  # ------------------ Publishing from $thisfn to $thistarget with $thisembstyle.
   
        unless ($ENV{'form.phase'} eq 'two') {         unless ($ENV{'form.phase'} eq 'two') {
          $r->print(     my ($outstring,$error)=&publish($thisfn,$thistarget,$thisembstyle);
           '<hr>'.&publish($thisfn,$thistarget,$thisembstyle));     $r->print('<hr />'.$outstring);
        } else {         } else {
          $r->print(             $r->print('<hr />');
           '<hr>'.&phasetwo($thisfn,$thistarget,$thisembstyle,$thisdistarget));              &phasetwo($r,$thisfn,$thistarget,$thisembstyle,$thisdistarget); 
        }           }
   
   }    }
   $r->print('</body></html>');    $r->print('</body></html>');
   
Removed from v.1.89  
changed lines
  Added in v.1.120

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