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

Diff for /loncom/publisher/lonpublisher.pm between versions 1.59 and 1.126

version 1.59, 2001/12/05 21:12:04 version 1.126, 2003/07/23 19:17:27
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/06,12/07 Gerd Kortemeyer
   # 12/25 Gerd Kortemeyer
   # YEAR=2002
   # 1/17 Gerd Kortemeyer
   #
   ###
   
   ###############################################################################
   ##                                                                           ##
   ## ORGANIZATION OF THIS PERL MODULE                                          ##
   ##                                                                           ##
   ## 1. Modules used by this module                                            ##
   ## 2. Various subroutines                                                    ##
   ## 3. Publication Step One                                                   ##
   ## 4. Phase Two                                                              ##
   ## 5. Main Handler                                                           ##
   ##                                                                           ##
   ###############################################################################
   
   
   ######################################################################
   ######################################################################
   
   =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
 use strict;  use strict;
 use Apache::File;  use Apache::File;
 use File::Copy;  use File::Copy;
 use Apache::Constants qw(:common :http :methods);  use Apache::Constants qw(:common :http :methods);
 use HTML::TokeParser;  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::loncommon();
   use Apache::lonmysql;
   use vars qw(%metadatafields %metadatakeys);
   
 my %addid;  my %addid;
 my %nokey;  my %nokey;
 my %language;  
 my %cprtag;  
   
 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;
         
         my $parser=HTML::TokeParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {             if ($token->[0] eq 'S') {
Line 88  sub metaeval { Line 180  sub metaeval {
               if (defined($token->[2]->{'name'})) {                 if (defined($token->[2]->{'name'})) { 
                  $unikey.='_'.$token->[2]->{'name'};                    $unikey.='_'.$token->[2]->{'name'}; 
       }        }
                map {                foreach (@{$token->[3]}) {
   $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};    $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};
                   if ($metadatakeys{$unikey}) {                    if ($metadatakeys{$unikey}) {
       $metadatakeys{$unikey}.=','.$_;        $metadatakeys{$unikey}.=','.$_;
                   } else {                    } else {
                       $metadatakeys{$unikey}=$_;                        $metadatakeys{$unikey}=$_;
                   }                    }
               } @{$token->[3]};                }
               if ($metadatafields{$unikey}) {                if ($metadatafields{$unikey}) {
   my $newentry=$parser->get_text('/'.$entry);    my $newentry=$parser->get_text('/'.$entry);
                   unless (($metadatafields{$unikey}=~/$newentry/) ||                    unless (($metadatafields{$unikey}=~/\Q$newentry\E/) ||
                           ($newentry eq '')) {                            ($newentry eq '')) {
                      $metadatafields{$unikey}.=', '.$newentry;                       $metadatafields{$unikey}.=', '.$newentry;
   }    }
Line 109  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 ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =  
  localtime(@_[0]);  sub coursedependencies {
     $mon++; $year+=1900;      my $url=&Apache::lonnet::declutter(shift);
     return "$year-$mon-$mday $hour:$min:$sec";      $url=~s/\.meta$//;
       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).
   
 # --------------------------------------------------------- Various form fields  =over 4
   
   =item B<textfield>
   
   =item B<hiddenfield>
   
   =item B<selectbox>
   
   =back
   
   =cut
   
   #########################################
   #########################################
 sub textfield {  sub textfield {
     my ($title,$name,$value)=@_;      my ($title,$name,$value)=@_;
     return "\n<p><b>$title:</b><br>".      my $uctitle=uc($title);
            '<input type=text name="'.$name.'" size=80 value="'.$value.'">';      return "\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".
              "</b></font></p><br />".
              '<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,%options)=@_;      my ($title,$name,$value,$functionref,@idlist)=@_;
     my $selout="\n<p><b>$title:</b><br>".'<select name="'.$name.'">';      my $uctitle=uc($title);
     map {      $value=(split(/\s*,\s*/,$value))[-1];
         $selout.='<option value="'.$_.'"';      my $selout="\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".
         if ($_ eq $value) { $selout.=' selected'; }   '</b></font></p><br /><select name="'.$name.'">';
         $selout.='>'.$options{$_}.'</option>';      foreach (@idlist) {
     } sort keys %options;          $selout.='<option value=\''.$_.'\'';
           if ($_ eq $value) {
       $selout.=' selected>'.&{$functionref}($_).'</option>';
    }
           else {$selout.='>'.&{$functionref}($_).'</option>';}
       }
     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 ''; }
       #javascript code needs no fixing
       if ($url =~ /^javascript:/i) { return $url; }
       if ($url =~ /^mailto:/i) { return $url; }
       #internal document links need no fixing
       if ($url =~ /^\#/) { return $url; } 
     my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/);      my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/);
     map {      foreach (values %Apache::lonnet::hostname) {
  if ($_ eq $host) {   if ($_ eq $host) {
     $url=~s/^http\:\/\///;      $url=~s/^http\:\/\///;
             $url=~s/^$host//;              $url=~s/^$host//;
         }          }
     } values %Apache::lonnet::hostname;      }
     if ($url=~/^http\:\/\//) { return $url; }      if ($url=~/^http\:\/\//) { return $url; }
     $url=~s/\~$cuname/res\/$cudom\/$cuname/;      $url=~s/\~$cuname/res\/$cudom\/$cuname/;
       return $url;
   }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<absoluteurl>
   
   Currently undocumented.
   
   =cut
   
   #########################################
   #########################################
   sub absoluteurl {
       my ($url,$target)=@_;
       unless ($url) { return ''; }
     if ($target) {      if ($target) {
  $target=~s/\/[^\/]+$//;   $target=~s/\/[^\/]+$//;
        $url=&Apache::lonnet::hreflocation($target,$url);         $url=&Apache::lonnet::hreflocation($target,$url);
Line 180  sub urlfixup { Line 387  sub urlfixup {
     return $url;      return $url;
 }  }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<set_allow>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
   sub set_allow {
       my ($allow,$logfile,$target,$tag,$oldurl)=@_;
       my $newurl=&urlfixup($oldurl,$target);
       my $return_url=$oldurl;
       print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n";
       if ($newurl ne $oldurl) {
    $return_url=$newurl;
    print $logfile 'URL: '.$tag.':'.$oldurl.' - '.$newurl."\n";
       }
       if (($newurl !~ /^javascript:/i) &&
    ($newurl !~ /^mailto:/i) &&
    ($newurl !~ /^http:/i) &&
    ($newurl !~ /^\#/)) {
    $$allow{&absoluteurl($newurl,$target)}=1;
       }
       return $return_url
   }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<get_subscribed_hosts>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
   sub get_subscribed_hosts {
       my ($target)=@_;
       my @subscribed;
       my $filename;
       $target=~/(.*)\/([^\/]+)$/;
       my $srcf=$2;
       opendir(DIR,$1);
       while ($filename=readdir(DIR)) {
    if ($filename=~/\Q$srcf\E\.(\w+)$/) {
       my $subhost=$1;
       if (($subhost ne 'meta' && $subhost ne 'subscription') &&
                   ($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) {
    push(@subscribed,$subhost);
       }
    }
       }
       closedir(DIR);
       my $sh;
       if ( $sh=Apache::File->new("$target.subscription") ) {
    &Apache::lonnet::logthis("opened $target.subscription");
    while (my $subline=<$sh>) {
       &Apache::lonnet::logthis("Trying $subline");
       if ($subline =~ /(^\w+):/) { 
                   if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) { 
                      push(@subscribed,$1);
           }
               } else {
    &Apache::lonnet::logthis("No Match for $subline");
       }
    }
       } else {
    &Apache::lonnet::logthis("Unable to open $target.subscription");
       }
       return @subscribed;
   }
   
   
   #########################################
   #########################################
   
   =pod
   
   =item B<get_max_ids_indices>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
   sub get_max_ids_indices {
       my ($content)=@_;
       my $maxindex=10;
       my $maxid=10;
       my $needsfixup=0;
       my $duplicateids=0;
   
       my %allids;
       my %duplicatedids;
   
       my $parser=HTML::LCParser->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;
    if (exists($allids{$token->[2]->{'id'}})) {
       $duplicateids=1;
       $duplicatedids{$token->[2]->{'id'}}=1;
    } else {
       $allids{$token->[2]->{'id'}}=1;
    }
       } else {
    $needsfixup=1;
       }
    } else {
       if (defined($token->[2]->{'index'})) {
    $maxindex=($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
       } else {
    $needsfixup=1;
       }
    }
       }
    }
       }
       return ($needsfixup,$maxid,$maxindex,$duplicateids,
       (keys(%duplicatedids)));
   }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<get_all_text_unbalanced>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
   sub get_all_text_unbalanced {
       #there is a copy of this in lonxml.pm
       my($tag,$pars)= @_;
       my $token;
       my $result='';
       $tag='<'.$tag.'>';
       while ($token = $$pars[-1]->get_token) {
    if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) {
       $result.=$token->[1];
    } elsif ($token->[0] eq 'PI') {
       $result.=$token->[2];
    } elsif ($token->[0] eq 'S') {
       $result.=$token->[4];
    } elsif ($token->[0] eq 'E')  {
       $result.=$token->[2];
    }
    if ($result =~ /(.*)\Q$tag\E(.*)/s) {
       #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2);
       #&Apache::lonnet::logthis('Result is :'.$1);
       $result=$1;
       my $redo=$tag.$2;
       push (@$pars,HTML::LCParser->new(\$redo));
       $$pars[-1]->xml_mode('1');
       last;
    }
       }
       return $result
   }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<fix_ids_and_indices>
   
   Currently undocumented    
   
   =cut
   
   #########################################
   #########################################
   #Arguably this should all be done as a lonnet::ssi instead
   sub fix_ids_and_indices {
       my ($logfile,$source,$target)=@_;
   
       my %allow;
       my $content;
       {
    my $org=Apache::File->new($source);
    $content=join('',<$org>);
       }
   
       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) {
    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;
       $parser[0]=HTML::LCParser->new(\$content);
       $parser[-1]->xml_mode(1);
       my $token;
       while (@parser) {
    while ($token=$parser[-1]->get_token) {
       if ($token->[0] eq 'S') {
    my $counter;
    my $tag=$token->[1];
    my $lctag=lc($tag);
    if ($lctag eq 'allow') {
       $allow{$token->[2]->{'src'}}=1;
       next;
    }
    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";
    }
       }
    }
    foreach my $type ('src','href','background','bgimg') {
       foreach my $key (keys(%parms)) {
    if ($key =~ /^$type$/i) {
       $parms{$key}=&set_allow(\%allow,$logfile,
       $target,$tag,
       $parms{$key});
    }
       }
    }
    # probably a <randomlabel> image type <label>
    if ($lctag eq 'label' && defined($parms{'description'})) {
       my $next_token=$parser[-1]->get_token();
       if ($next_token->[0] eq 'T') {
    $next_token->[1]=&set_allow(\%allow,$logfile,
       $target,$tag,
       $next_token->[1]);
       }
       $parser[-1]->unget_token($next_token);
    }
    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{&absoluteurl($codebase,$target).'/*'}=1;
       } else {
    foreach ('archive','code','object') {
       if (defined($parms{$_})) {
    my $oldurl=$parms{$_};
    my $newurl=&urlfixup($oldurl,$target);
    $newurl=~s/\/[^\/]+$/\/\*/;
    print $logfile 'Allow: applet '.$_.':'.
       $oldurl.' allows '.
    $newurl."\n";
    $allow{&absoluteurl($newurl,$target)}=1;
       }
    }
       }
    }
    my $newparmstring='';
    my $endtag='';
    foreach (keys %parms) {
       if ($_ eq '/') {
    $endtag=' /';
       } else { 
    my $quote=($parms{$_}=~/\"/?"'":'"');
    $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
       }
    }
    if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
    $outstring.='<'.$tag.$newparmstring.$endtag.'>';
    if ($lctag eq 'm') {
       $outstring.=&get_all_text_unbalanced('/m',\@parser);
    }
       } elsif ($token->[0] eq 'E') {
    if ($token->[2]) {
       unless ($token->[1] eq 'allow') {
    $outstring.='</'.$token->[1].'>';
       }
    }
       } else {
    $outstring.=$token->[1];
       }
    }
    pop(@parser);
       }
   
       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";
       }
   
       return ($outstring,0,%allow);
   }
   
   #########################################
   #########################################
   
   =pod
   
   =item B<store_metadata>
   
   Store the metadata in the metadata table in the loncapa database.
   Uses lonmysql to access the database.
   
   Inputs: \%metadata
   
   Returns: (error,status).  error is undef on success, status is undef on error.
   
   =cut
   
   #########################################
   #########################################
   sub store_metadata {
       my %metadata = %{shift()};
       my $error;
       # Determine if the table exists
       my $status = &Apache::lonmysql::check_table('metadata');
       if (! defined($status)) {
           $error='<font color="red">WARNING: Cannot connect to '.
               'database!</font>';
           &Apache::lonnet::logthis($error);
           return ($error,undef);
       }
       if ($status == 0) {
           # It would be nice to actually create the table....
           $error ='<font color="red">WARNING: The metadata table does not '.
               'exist in the LON-CAPA database.</font>';
           &Apache::lonnet::logthis($error);
           return ($error,undef);
       }
       # Remove old value from table
       $status = &Apache::lonmysql::remove_from_table
           ('metadata','url',$metadata{'url'});
       if (! defined($status)) {
           $error = '<font color="red">Error when removing old values from '.
               'metadata table in LON-CAPA database.</font>';
           &Apache::lonnet::logthis($error);
           return ($error,undef);
       }
       # Store data in table.
       $status = &Apache::lonmysql::store_row('metadata',\%metadata);
       if (! defined($status)) {
           $error='<font color="red">Error occured storing new values in '.
               'metadata table in LON-CAPA database</font>';
           &Apache::lonnet::logthis($error);
           return ($error,undef);
       }
       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='';
     my $content='';      my $content='';
     my %allow=();      my %allow=();
     undef %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".$ENV{'user.name'}.'@'.$ENV{'user.domain'}."\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 206  sub publish { Line 826  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 $maxindex=10;   my ($outstring,$error);
         my $maxid=10;   ($outstring,$error,%allow)=&fix_ids_and_indices($logfile,$source,
    $target);
         my $needsfixup=0;   if ($error) { return ($outstring,$error); }
   
         {  
           my $org=Apache::File->new($source);  
           $content=join('',<$org>);  
         }  
         {  
           my $parser=HTML::TokeParser->new(\$content);  
           my $token;  
           while ($token=$parser->get_token) {  
               if ($token->[0] eq 'S') {  
                   my $counter;  
   if ($counter=$addid{$token->[1]}) {  
       if ($counter eq 'id') {  
   if (defined($token->[2]->{'id'})) {  
                              $maxid=  
        ($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;  
  } else {  
                              $needsfixup=1;  
                          }  
                       } else {  
    if (defined($token->[2]->{'index'})) {  
                              $maxindex=  
    ($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;  
   } else {  
                              $needsfixup=1;  
   }  
       }  
   }  
               }  
           }  
       }  
       if ($needsfixup) {  
           print $logfile "Needs ID and/or index fixup\n".  
         "Max ID   : $maxid (min 10)\n".  
                 "Max Index: $maxindex (min 10)\n";  
       }  
           my $outstring='';  
           my $parser=HTML::TokeParser->new(\$content);  
           $parser->xml_mode(1);  
           my $token;  
           while ($token=$parser->get_token) {  
               if ($token->[0] eq 'S') {  
                 my $counter;  
                 my $tag=$token->[1];  
                 my $lctag=lc($tag);  
                 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;  
   if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }  
   $outstring.='<'.$tag.$newparmstring.$endtag.'>';  
          } else {  
    $allow{$token->[2]->{'src'}}=1;  
  }  
               } elsif ($token->[0] eq 'E') {  
  if ($token->[2]) {  
                   unless ($token->[1] eq 'allow') {  
                      $outstring.='</'.$token->[1].'>';  
   }  
  }  
               } else {  
                   $outstring.=$token->[1];  
               }  
           }  
 # ------------------------------------------------------------ Construct Allows  # ------------------------------------------------------------ Construct Allows
      unless ($style eq 'rat') {      
  $scrout.='<h3>Dependencies</h3>';   $scrout.='<h3>Dependencies</h3>';
  my $allowstr="\n";          my $allowstr='';
         map {          foreach (sort(keys(%allow))) {
    my $thisdep=$_;     my $thisdep=$_;
            $allowstr.='<allow src="'.$thisdep.'" />'."\n";     if ($thisdep !~ /[^\s]/) { next; }
            $scrout.='<br>';             unless ($style eq 'rat') { 
                 $allowstr.="\n".'<allow src="'.$thisdep.'" />';
      }
              $scrout.='<br />';
            unless ($thisdep=~/\*/) {             unless ($thisdep=~/\*/) {
        $scrout.='<a href="'.$thisdep.'">';         $scrout.='<a href="'.$thisdep.'">';
            }             }
Line 365  sub publish { Line 854  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);
    }     }
        }         }
            }             }
         } keys %allow;          }
         $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s;          $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s;
     }  
 # ------------------------------------------------------------- Write modified   #Encode any High ASCII characters
    $outstring=&HTML::Entities::encode($outstring,"\200-\377");
   # ------------------------------------------------------------- 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;
   
       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  # -------------------------------------------- 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=();
             
      $scrout.='<h3>Metadata Information</h3>';      unless ($batch) {
        $scrout.='<h3>Metadata Information ' .
          Apache::loncommon::help_open_topic("Metadata_Description")
          . '</h3>';
       }
   
 # ------------------------------------------------ First, check out environment  # ------------------------------------------------ First, check out environment
      unless (-e $source.'.meta') {       unless (-e $source.'.meta') {
Line 421  sub publish { Line 910  sub publish {
         $metadatafields{'author'}=~s/\s+/ /g;          $metadatafields{'author'}=~s/\s+/ /g;
         $metadatafields{'author'}=~s/\s+$//;          $metadatafields{'author'}=~s/\s+$//;
         $metadatafields{'owner'}=$cuname.'@'.$cudom;          $metadatafields{'owner'}=$cuname.'@'.$cudom;
    $metadatafields{'modifyinguser'}=$ENV{'user.name'}.'@'.
                                    $ENV{'user.domain'};
    $metadatafields{'authorspace'}=$cuname.'@'.$cudom;
   
 # ------------------------------------------------ Check out directory hierachy  # ------------------------------------------------ Check out directory hierachy
   
         my $thisdisfn=$source;          my $thisdisfn=$source;
         $thisdisfn=~s/^\/home\/$cuname\///;          $thisdisfn=~s/^\/home\/\Q$cuname\E\///;
   
         my @urlparts=split(/\//,$thisdisfn);          my @urlparts=split(/\//,$thisdisfn);
         $#urlparts--;          $#urlparts--;
   
         my $currentpath='/home/'.$cuname.'/';          my $currentpath='/home/'.$cuname.'/';
   
         map {          foreach (@urlparts) {
     $currentpath.=$_.'/';      $currentpath.=$_.'/';
             $scrout.=&metaread($logfile,$currentpath.'default.meta');              $scrout.=&metaread($logfile,$currentpath.'default.meta');
         } @urlparts;          }
   
 # ------------------- Clear out parameters and stores (there should not be any)  # ------------------- Clear out parameters and stores (there should not be any)
   
         map {          foreach (keys %metadatafields) {
     if (($_=~/^parameter/) || ($_=~/^stores/)) {      if (($_=~/^parameter/) || ($_=~/^stores/)) {
  delete $metadatafields{$_};   delete $metadatafields{$_};
             }              }
         } keys %metadatafields;          }
   
     } else {      } else {
 # ---------------------- Read previous metafile, remember parameters and stores  # ---------------------- Read previous metafile, remember parameters and stores
   
         $scrout.=&metaread($logfile,$source.'.meta');          $scrout.=&metaread($logfile,$source.'.meta');
   
         map {          foreach (keys %metadatafields) {
     if (($_=~/^parameter/) || ($_=~/^stores/)) {      if (($_=~/^parameter/) || ($_=~/^stores/)) {
                 $oldparmstores{$_}=1;                  $oldparmstores{$_}=1;
  delete $metadatafields{$_};   delete $metadatafields{$_};
             }              }
         } keys %metadatafields;          }
                   
     }      }
   
 # -------------------------------------------------- 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;
         $allmeta=Apache::lonxml::xmlparse('meta',$content);          $allmeta=Apache::lonxml::xmlparse(undef,'meta',$content);
         $ENV{'request.uri'}=$oldenv;          $ENV{'request.uri'}=$oldenv;
   
         &metaeval($allmeta);          &metaeval($allmeta);
     }      }
 # ---------------- Find and document discrepancies in the parameters and stores  # ---------------- Find and document discrepancies in the parameters and stores
   
         my $chparms='';      my $chparms='';
         map {      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.=$_.' ';
                    }   }
         }      }
             }   }
         } sort keys %metadatafields;      }
         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;      }
         }  
   
         my $chparms='';      $chparms='';
         map {      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.=$_.' ';
                 }      }
             }   }
         } sort keys %oldparmstores;      }
         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 action="/adm/publish" method="post">'.      '<form name="pubform" action="/adm/publish" method="post">'.
           &hiddenfield('phase','two').              '<p><input type="submit" value="Finalize Publication" /></p>'.
           &hiddenfield('filename',$ENV{'form.filename'}).              &hiddenfield('phase','two').
   &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).              &hiddenfield('filename',$ENV{'form.filename'}).
           &hiddenfield('dependencies',join(',',keys %allow)).      &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).
           &textfield('Title','title',$metadatafields{'title'}).              &hiddenfield('dependencies',join(',',keys %allow)).
           &textfield('Author(s)','author',$metadatafields{'author'}).              &textfield('Title','title',$metadatafields{'title'}).
   &textfield('Subject','subject',$metadatafields{'subject'});              &textfield('Author(s)','author',$metadatafields{'author'}).
       &textfield('Subject','subject',$metadatafields{'subject'});
   
 # --------------------------------------------------- Scan content for keywords  # --------------------------------------------------- Scan content for keywords
   
  my $keywordout='<p><b>Keywords:</b><br><table border=2><tr>';          my $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords");
         my $colcount=0;   my $keywordout=<<"END";
           <script>
  if (length($content)<500000) {  function checkAll(field) {
     my $textonly=$content;      for (i = 0; i < field.length; i++)
             $textonly=~s/\<script[^\<]+\<\/script\>//g;          field[i].checked = true ;
             $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 {  function uncheckAll(field) {
                 $keywordout.='<td><input type=checkbox name="key.'.$_.'"';      for (i = 0; i < field.length; i++)
                 if ($metadatafields{'keywords'}=~/$_/) {           field[i].checked = false ;
                    $keywordout.=' checked';   }
                 }  </script>
                 $keywordout.='>'.$_.'</td>';  <p><font color="#800000" face="helvetica"><b>KEYWORDS:</b></font>
                 if ($colcount>10) {   $keywords_help</b>
     $keywordout.="</tr><tr>\n";  <input type="button" value="check all" onclick="javascript:checkAll(document.pubform.keywords)" /> 
                     $colcount=0;  <input type="button" value="uncheck all" onclick="javascript:uncheckAll(document.pubform.keywords)" /> 
                 }  </p>
                 $colcount++;  <br />
             } sort keys %keywords;  END
    $keywordout.='<table border="2"><tr>';
    my $colcount=0;
   
    foreach (sort keys %keywords) {
       $keywordout.='<td><input type="checkbox" name="keywords" value="'.$_.'"';
       if ($metadatafields{'keywords'}) {
    if ($metadatafields{'keywords'}=~/\Q$_\E/) {
       $keywordout.=' checked="on"';
    }
       } elsif (&Apache::loncommon::keyword($_)) {
    $keywordout.=' checked="on"';
       }
       $keywordout.=' />'.$_.'</td>';
       if ($colcount>10) {
    $keywordout.="</tr><tr>\n";
    $colcount=0;
       }
       $colcount++;
    }
   
         } else {  
     $keywordout.='<td>File too long for keyword analysis</td>';  
         }           
           
  $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>'.      "\n<p><font color=\"#800000\" face=\"helvetica\"><b>ABSTRACT:".
               $metadatafields{'abstract'}.'</textarea>';      "</b></font></p><br />".
       '<textarea cols="80" rows="5" name="abstract">'.
       $metadatafields{'abstract'}.'</textarea></p>';
   
  $source=~/\.(\w+)$/;   $source=~/\.(\w+)$/;
   
  $scrout.=&hiddenfield('mime',$1);   $scrout.=&hiddenfield('mime',$1);
   
         $scrout.=&selectbox('Language','language',   my $defaultlanguage=$metadatafields{'language'};
                             $metadatafields{'language'},%language);   $defaultlanguage =~ s/\s*notset\s*//g;
    $defaultlanguage =~ s/^,\s*//g;
    $defaultlanguage =~ s/,\s*$//g;
   
    $scrout.=&selectbox('Language','language',
       $defaultlanguage,
       \&Apache::loncommon::languagedescription,
       (&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',  
                             $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',   $scrout.=&textfield('Publisher/Owner','owner',
                             $metadatafields{'copyright'},%cprtag);      $metadatafields{'owner'});
   
     return $scrout.  # -------------------------------------------------- Correct copyright for rat.
       '<p><input type="submit" value="Finalize Publication"></form>';          my $defaultoption=$metadatafields{'copyright'};
           unless ($defaultoption) { $defaultoption='default'; }
    unless ($style eq 'prv') {
       if ($style eq 'rat') {
    if ($metadatafields{'copyright'} eq 'public') { 
       delete $metadatafields{'copyright'};
                       $defaultoption='default';
    }
    $scrout.=&selectbox('Copyright/Distribution','copyright',
       $defaultoption,
       \&Apache::loncommon::copyrightdescription,
       (grep !/^public$/,(&Apache::loncommon::copyrightids)));
       } else {
    $scrout.=&selectbox('Copyright/Distribution','copyright',
       $defaultoption,
       \&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');
    }
    return ($scrout.'<p><input type="submit" value="Finalize Publication" /></p></form>',0);
   # =============================================================================
   # BATCH MODE
   #
       } else {
   # Transfer metadata directly to environment for stage 2
    foreach (keys %metadatafields) {
       $ENV{'form.'.$_}=$metadatafields{$_};
    }
    $ENV{'form.addkey'}='';
    $ENV{'form.keywords'}='';
    foreach (keys %keywords) {
       if ($metadatafields{'keywords'}) {
    if ($metadatafields{'keywords'}=~/\Q$_\E/) { 
       $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);
       }
 }  }
   
 # -------------------------------------------------------- Publication Step Two  #########################################
   #########################################
   
 sub phasetwo {  =pod 
   
     my ($source,$target,$style,$distarget)=@_;  =item B<phasetwo>
     my $logfile;  
     my $scrout='';  
   
     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {  Render second interface showing status of publication steps.
  return   This is publication step two.
          '<font color=red>No write permission to user directory, FAIL</font>';  
     }  
     print $logfile   
 "\n================= Publish ".localtime()." Phase Two  ================\n";  
   
      %metadatafields=();  Parameters:
      %metadatakeys=();  
   
      &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'}));  =over 4
   
      $metadatafields{'title'}=$ENV{'form.title'};  =item I<$source>
      $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  =item I<$target>
     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;  
  }  
     }  
     close(CONFIG);  
   
     my $warning;  =item I<$style>
     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";  
  }  
     }  
   
   =item I<$distarget>
   
 # ----------------------------------------------------------- Copy old versions  =back
      
 if (-e $target) {  Returns:
     my $filename;  
     my $maxversion=0;  =over 4
     $target=~/(.*)\/([^\/]+)\.(\w+)$/;  
     my $srcf=$2;  =item Scalar string
     my $srct=$3;  
     my $srcd=$1;  String contains status (errors and warnings) and information associated with
     unless ($srcd=~/^\/home\/httpd\/html\/res/) {  the server's attempts at publication.     
  print $logfile "\nPANIC: Target dir is ".$srcd;  
         return "<font color=red>Invalid target directory, FAIL</font>";  =cut
   
   #'stupid emacs
   #########################################
   #########################################
   sub phasetwo {
   
       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;
     }      }
     opendir(DIR,$srcd);      $distarget=~s/\/+/\//g;
     while ($filename=readdir(DIR)) {      my $logfile;
        if ($filename=~/$srcf\.(\d+)\.$srct$/) {      unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
    $maxversion=($1>$maxversion)?$1:$maxversion;   $r->print(
        }          '<font color="red">No write permission to user directory, FAIL</font>');
           return 0;
     }      }
     closedir(DIR);      print $logfile 
     $maxversion++;          "\n================= Publish ".localtime()." Phase Two  ================\n".$ENV{'user.name'}.'@'.$ENV{'user.domain'}."\n";
     $scrout.='<p>Creating old version '.$maxversion;      
     print $logfile "\nCreating old version ".$maxversion;      %metadatafields=();
       %metadatakeys=();
     my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct;      
       &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'};
       $metadatafields{'customdistributionfile'}=
                                    $ENV{'form.customdistributionfile'};
       $metadatafields{'dependencies'}=$ENV{'form.dependencies'};
       
       my $allkeywords=$ENV{'form.addkey'};
       if (exists($ENV{'form.keywords'})) {
           if (ref($ENV{'form.keywords'})) {
               $allkeywords .= ','.join(',',@{$ENV{'form.keywords'}});
           } else {
               $allkeywords .= ','.$ENV{'form.keywords'};
           }
       }
       $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>';
           }
           foreach (sort keys %metadatafields) {
               unless ($_=~/\./) {
                   my $unikey=$_;
                   $unikey=~/^([A-Za-z]+)/;
                   my $tag=$1;
                   $tag=~tr/A-Z/a-z/;
                   print $mfh "\n\<$tag";
                   foreach (split(/\,/,$metadatakeys{$unikey})) {
                       my $value=$metadatafields{$unikey.'.'.$_};
                       $value=~s/\"/\'\'/g;
                       print $mfh ' '.$_.'="'.$value.'"';
                   }
                   print $mfh '>'.
                       &HTML::Entities::encode($metadatafields{$unikey})
                           .'</'.$tag.'>';
               }
           }
           $r->print('<p>Wrote Metadata</p>');
           print $logfile "\nWrote metadata";
       }
       
   # -------------------------------- Synchronize entry with SQL metadata database
   
       $metadatafields{'url'} = $distarget;
       $metadatafields{'version'} = 'current';
       unless ($metadatafields{'copyright'} eq 'priv') {
           my ($error,$success) = &store_metadata(\%metadatafields);
           if ($success) {
               $r->print('<p>Synchronized SQL metadata database</p>');
               print $logfile "\nSynchronized SQL metadata database";
           } else {
               $r->print($error);
               print $logfile "\n".$error;
           }
       } else {
           $r->print('<p>Private Publication - did not synchronize database</p>');
           print $logfile "\nPrivate: Did not synchronize data into ".
               "SQL metadata database";
       }
   # ----------------------------------------------------------- Copy old versions
      
       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 (-l $srcd.'/'.$filename) {
                   unlink($srcd.'/'.$filename);
                   unlink($srcd.'/'.$filename.'.meta');
               } else {
                   if ($filename=~/\Q$srcf\E\.(\d+)\.\Q$srct\E$/) {
                       $maxversion=($1>$maxversion)?$1:$maxversion;
                   }
               }
           }
           closedir(DIR);
           $maxversion++;
           $r->print('<p>Creating old version '.$maxversion.'</p>');
           print $logfile "\nCreating old version ".$maxversion."\n";
           
           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 $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;
               $r->print('<p>Created directory '.$parts[$count].'</p>');
               mkdir($path,0777);
           }
       }
       
       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
   
            my @parts=split(/\//,$copyfile);      $copyfile=$copyfile.'.meta';
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";      
       if (copy($source.'.meta',$copyfile)) {
           print $logfile "\nCopied original metadata to ".$copyfile."\n";
           $r->print('<p>Copied metadata</p>');
       } else {
           print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n";
           return 
               "<font color=\"red\">Failed to write metadata copy, $!, FAIL</font>";
       }
       $r->rflush;
   # --------------------------------------------------- Send update notifications
   
            my $count;      my @subscribed=&get_subscribed_hosts($target);
            for ($count=5;$count<$#parts;$count++) {      foreach my $subhost (@subscribed) {
                $path.="/$parts[$count]";   $r->print('<p>Notifying host '.$subhost.':');$r->rflush;
                if ((-e $path)!=1) {   print $logfile "\nNotifying host ".$subhost.':';
                    print $logfile "\nCreating directory ".$path;   my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);
                    $scrout.='<p>Created directory '.$parts[$count];   $r->print($reply.'</p><br />');$r->rflush;
    mkdir($path,0777);   print $logfile $reply;
                }      }
            }      
   # ---------------------------------------- Send update notifications, meta only
   
         if (copy($source,$copyfile)) {      my @subscribedmeta=&get_subscribed_hosts("$target.meta");
     print $logfile "Copied original source to ".$copyfile."\n";      foreach my $subhost (@subscribedmeta) {
             $scrout.='<p>Copied source file';   $r->print('<p>Notifying host for metadata only '.$subhost.':');$r->rflush;
         } else {   print $logfile "\nNotifying host for metadata only ".$subhost.':';
     print $logfile "Unable to write ".$copyfile.':'.$!."\n";   my $reply=&Apache::lonnet::critical('update:'.$target.'.meta',
             return "<font color=red>Failed to copy source, $!, FAIL</font>";      $subhost);
         }   $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;
       }
   # ------------------------------------------------ Provide link to new resource
       unless ($batch) {
           my $thisdistarget=$target;
           $thisdistarget=~s/^\Q$docroot\E//;
           
           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>');
       }
   }
   
 # --------------------------------------------------------------- Copy Metadata  #########################################
   
         $copyfile=$copyfile.'.meta';  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/^\Q$docroot\E//;
   
         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      undef %metadatafields;
       undef %metadatakeys;
        %metadatafields=();
        %metadatakeys=();
         $srcfile=~/\.(\w+)$/;
         my $thistype=$1;
   
 {  
   
     my $filename;        my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
         
     $target=~/(.*)\/([^\/]+)$/;      $r->print('<h2>Publishing <tt>'.$thisdisfn.'</tt></h2>');
     my $srcf=$2;  
     opendir(DIR,$1);  # phase one takes
     while ($filename=readdir(DIR)) {  #  my ($source,$target,$style,$batch)=@_;
        if ($filename=~/$srcf\.(\w+)$/) {      my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1);
    my $subhost=$1;      $r->print('<p>'.$outstring.'</p>');
            if ($subhost ne 'meta') {  # phase two takes
        $scrout.='<p>Notifying host '.$subhost.':';  # my ($source,$target,$style,$distarget,batch)=@_;
                print $logfile "\nNotifying host '.$subhost.':'";  # $ENV{'form.allmeta'},$ENV{'form.title'},$ENV{'form.author'},...
                my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);      if (!$error) {
                $scrout.=$reply;   $r->print('<p>');
                print $logfile $reply;                 &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1);
            }   $r->print('</p>');
        }  
     }      }
     closedir(DIR);      return '';
   }
   
   #########################################
   
   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) || ($ENV{'form.forcerepub'})) {
   # 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);
 }  }
   #########################################
   
 # ---------------------------------------- Send update notifications, meta only  =pod
   
 {  =item B<handler>
   
     my $filename;  A basic outline of the handler subroutine follows.
    
     $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);  
   
 }  =over 4
   
 # ------------------------------------------------ Provide link to new resource  =item *
   
     my $thisdistarget=$target;  Get query string for limited number of parameters.
     $thisdistarget=~s/^$docroot//;  
   
     my $thissrc=$source;  =item *
     $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/;  
   
     my $thissrcdir=$thissrc;  Check filename.
     $thissrcdir=~s/\/[^\/]+$/\//;  
   
   =item *
   
     return $warning.$scrout.  File is there and owned, init lookup tables.
       '<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>';  
   
 }  =item *
   
   Start page output.
   
 # ================================================================ Main Handler  =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 909  sub handler { Line 1615  sub handler {
   
 # Get query string for limited number of parameters  # Get query string for limited number of parameters
   
     map {      &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
        my ($name, $value) = split(/=/,$_);                                              ['filename']);
        $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=&Apache::lonnet::unescape($ENV{'form.filename'});
   
       
   unless ($fn) {     unless ($fn) { 
Line 978  sub handler { Line 1675  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 993  unless ($ENV{'form.phase'} eq 'two') { Line 1690  unless ($ENV{'form.phase'} eq 'two') {
   
   {    {
      my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab');       my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab');
       map {        while (<$fh>) {
           my $word=$_;            my $word=$_;
           chomp($word);            chomp($word);
           $nokey{$word}=1;            $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(    $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::lonnet::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;    my $thisdistarget=$thistarget;
       $thisdistarget=~s/^$docroot//;    $thisdistarget=~s/^\Q$docroot\E//;
   
       my $thisdisfn=$thisfn;    my $thisdisfn=$thisfn;
       $thisdisfn=~s/^\/home\/$cuname\/public_html\///;    $thisdisfn=~s/^\/home\/\Q$cuname\E\/public_html\///;
   
     if ($fn=~/\/$/) {
   # -------------------------------------------------------- This is a directory
         &publishdirectory($r,$fn,$thisdisfn);
   
     } else {
   # ---------------------- 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::lonnet::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::lonnet::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>');
   
Line 1083  unless ($ENV{'form.phase'} eq 'two') { Line 1765  unless ($ENV{'form.phase'} eq 'two') {
 1;  1;
 __END__  __END__
   
   =pod
   
   =back
   
   =back
   
   =cut
   
   
Removed from v.1.59  
changed lines
  Added in v.1.126

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