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

Diff for /loncom/publisher/lonpublisher.pm between versions 1.64 and 1.65

version 1.64, 2001/12/07 22:37:56 version 1.65, 2001/12/15 18:15:27
Line 41 Line 41
 # 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 Scott Harrison
   #
   ###
   
   ###############################################################################
   ##                                                                           ##
   ## ORGANIZATION OF THIS PERL MODULE                                          ##
   ##                                                                           ##
   ## 1. Modules used by this module                                            ##
   ## 2. Various subroutines                                                    ##
   ## 3. Publication Step One                                                   ##
   ## 4. Phase Two                                                              ##
   ## 5. Main Handler                                                           ##
   ##                                                                           ##
   ###############################################################################
   
 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;
Line 53  use Apache::lonxml; Line 69  use Apache::lonxml;
 use Apache::lonhomework;  use Apache::lonhomework;
 use Apache::loncacc;  use Apache::loncacc;
 use DBI;  use DBI;
   use Apache::lonnet();
   use Apache::loncommon();
   
 my %addid;  my %addid;
 my %nokey;  my %nokey;
 my %language;  
 my %cprtag;  
   
 my %metadatafields;  my %metadatafields;
 my %metadatakeys;  my %metadatakeys;
Line 68  my $cuname; Line 84  my $cuname;
 my $cudom;  my $cudom;
   
 # ----------------------------------------------- Evaluate string with metadata  # ----------------------------------------------- Evaluate string with metadata
   
 sub metaeval {  sub metaeval {
     my $metastring=shift;      my $metastring=shift;
         
Line 90  sub metaeval { Line 105  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}=~/$newentry/) ||
Line 112  sub metaeval { Line 127  sub metaeval {
 }  }
   
 # -------------------------------------------------------- Read a metadata file  # -------------------------------------------------------- Read a metadata file
   
 sub metaread {  sub metaread {
     my ($logfile,$fn)=@_;      my ($logfile,$fn)=@_;
     unless (-e $fn) {      unless (-e $fn) {
Line 151  sub hiddenfield { Line 165  sub hiddenfield {
 }  }
   
 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 {      my $selout="\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".
         $selout.='<option value="'.$_.'"';   "</b></font><br />".'<select name="'.$name.'">';
         if ($_ eq $value) { $selout.=' selected'; }      foreach (@idlist) {
         $selout.='>'.$options{$_}.'</option>';          $selout.='<option value=\''.$_.'\'';
     } sort keys %options;          if ($_ eq $value) {
       $selout.=' selected>'.&{$functionref}($_).'</option>';
    }
           else {$selout.='>'.&{$functionref}($_).'</option>';}
       }
     return $selout.'</select>';      return $selout.'</select>';
 }  }
   
Line 167  sub urlfixup { Line 185  sub urlfixup {
     my ($url,$target)=@_;      my ($url,$target)=@_;
     unless ($url) { return ''; }      unless ($url) { return ''; }
     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/;
     if ($target) {      if ($target) {
Line 281  sub publish { Line 299  sub publish {
       }        }
   }     } 
                                       
                   map {                    foreach ('src','href','background') {
                       if (defined($parms{$_})) {                        if (defined($parms{$_})) {
   my $oldurl=$parms{$_};    my $oldurl=$parms{$_};
                           my $newurl=&urlfixup($oldurl,$target);                            my $newurl=&urlfixup($oldurl,$target);
Line 292  sub publish { Line 310  sub publish {
   }    }
                           $allow{$newurl}=1;                            $allow{$newurl}=1;
                       }                        }
                   } ('src','href','background');                    }
   
                   if ($lctag eq 'applet') {                    if ($lctag eq 'applet') {
       my $codebase='';        my $codebase='';
Line 311  sub publish { Line 329  sub publish {
  }   }
                          $allow{$codebase.'/*'}=1;                           $allow{$codebase.'/*'}=1;
       } else {        } else {
                         map {                          foreach ('archive','code','object') {
                           if (defined($parms{$_})) {                            if (defined($parms{$_})) {
       my $oldurl=$parms{$_};        my $oldurl=$parms{$_};
                               my $newurl=&urlfixup($oldurl,$target);                                my $newurl=&urlfixup($oldurl,$target);
Line 321  sub publish { Line 339  sub publish {
   $newurl."\n";    $newurl."\n";
                               $allow{$newurl}=1;                                $allow{$newurl}=1;
                           }                            }
                         } ('archive','code','object');                          }
                       }                        }
                   }                    }
   
                   my $newparmstring='';                    my $newparmstring='';
                   my $endtag='';                    my $endtag='';
                   map {                    foreach (keys %parms) {
                     if ($_ eq '/') {                      if ($_ eq '/') {
                       $endtag=' /';                        $endtag=' /';
                     } else {                       } else { 
                       my $quote=($parms{$_}=~/\"/?"'":'"');                        my $quote=($parms{$_}=~/\"/?"'":'"');
                       $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;                        $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
     }      }
                   } keys %parms;                    }
   if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }    if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
   $outstring.='<'.$tag.$newparmstring.$endtag.'>';    $outstring.='<'.$tag.$newparmstring.$endtag.'>';
          } else {           } else {
Line 354  sub publish { Line 372  sub publish {
           
  $scrout.='<h3>Dependencies</h3>';   $scrout.='<h3>Dependencies</h3>';
         my $allowstr='';          my $allowstr='';
         map {          foreach (keys %allow) {
    my $thisdep=$_;     my $thisdep=$_;
            unless ($style eq 'rat') {              unless ($style eq 'rat') { 
               $allowstr.="\n".'<allow src="'.$thisdep.'" />';                $allowstr.="\n".'<allow src="'.$thisdep.'" />';
Line 381  sub publish { Line 399  sub publish {
    }     }
        }         }
            }             }
         } keys %allow;          }
         $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s;          $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s;
   
 # ------------------------------------------------------------- Write modified  # ------------------------------------------------------------- Write modified
Line 436  sub publish { Line 454  sub publish {
   
         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;          }
                   
     }      }
   
Line 476  sub publish { Line 494  sub publish {
 # ---------------- 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{$_}) {
Line 485  sub publish { Line 503  sub publish {
                    }                     }
         }          }
             }              }
         } 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;                       $chparms;
         }          }
   
         my $chparms='';          my $chparms='';
         map {          foreach (sort keys %oldparmstores) {
     if (($_=~/^parameter/) || ($_=~/^stores/)) {      if (($_=~/^parameter/) || ($_=~/^stores/)) {
                 unless (($metadatafields{$_.'.name'}) ||                  unless (($metadatafields{$_.'.name'}) ||
                         ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) {                          ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) {
Line 500  sub publish { Line 518  sub publish {
                     $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;
Line 534  sub publish { Line 552  sub publish {
             $textonly=~s/[^a-z\s]//g;              $textonly=~s/[^a-z\s]//g;
   
             my %keywords=();              my %keywords=();
             map {              foreach ($textonly=~m/(\w+)/g) {
  unless ($nokey{$_}) {   unless ($nokey{$_}) {
                    $keywords{$_}=1;                     $keywords{$_}=1;
                 }                   } 
             } ($textonly=~m/(\w+)/g);              }
   
             map {              foreach (split(/\W+/,$metadatafields{'keywords'})) {
  $keywords{$_}=1;   $keywords{$_}=1;
             } split(/\W+/,$metadatafields{'keywords'});              }
   
             map {              foreach (sort keys %keywords) {
                 $keywordout.='<td><input type=checkbox name="key.'.$_.'"';                  $keywordout.='<td><input type=checkbox name="key.'.$_.'"';
                 if ($metadatafields{'keywords'}=~/$_/) {                   if ($metadatafields{'keywords'}=~/$_/) { 
                    $keywordout.=' checked';                      $keywordout.=' checked'; 
Line 555  sub publish { Line 573  sub publish {
                     $colcount=0;                      $colcount=0;
                 }                  }
                 $colcount++;                  $colcount++;
             } sort keys %keywords;              }
   
         } else {          } else {
     $keywordout.='<td>File too long for keyword analysis</td>';      $keywordout.='<td>File too long for keyword analysis</td>';
Line 578  sub publish { Line 596  sub publish {
  $scrout.=&hiddenfield('mime',$1);   $scrout.=&hiddenfield('mime',$1);
   
         $scrout.=&selectbox('Language','language',          $scrout.=&selectbox('Language','language',
                             $metadatafields{'language'},%language);                              $metadatafields{'language'},
       \&{Apache::loncommon::languagedescription},
       (&Apache::loncommon::languageids),
        );
   
         unless ($metadatafields{'creationdate'}) {          unless ($metadatafields{'creationdate'}) {
     $metadatafields{'creationdate'}=time;      $metadatafields{'creationdate'}=time;
Line 592  sub publish { Line 613  sub publish {
                             $metadatafields{'owner'});                              $metadatafields{'owner'});
 # --------------------------------------------------- Correct copyright for rat          # --------------------------------------------------- Correct copyright for rat        
     if ($style eq 'rat') {      if ($style eq 'rat') {
        if ($metadatafields{'copyright'} eq 'public') {    if ($metadatafields{'copyright'} eq 'public') { 
           delete $metadatafields{'copyright'};      delete $metadatafields{'copyright'};
        }   }
        delete $cprtag{'public'};  
    }  
   
         $scrout.=&selectbox('Copyright/Distribution','copyright',          $scrout.=&selectbox('Copyright/Distribution','copyright',
                             $metadatafields{'copyright'},%cprtag);                              $metadatafields{'copyright'},
       \&{Apache::loncommon::copyrightdescription},
        (grep !/^public$/,(&Apache::loncommon::copyrightids)));
       }
       else {
           $scrout.=&selectbox('Copyright/Distribution','copyright',
                               $metadatafields{'copyright'},
       \&{Apache::loncommon::copyrightdescription},
        (&Apache::loncommon::copyrightids));
       }
     return $scrout.      return $scrout.
       '<p><input type="submit" value="Finalize Publication" /></p></form>';        '<p><input type="submit" value="Finalize Publication" /></p></form>';
 }  }
Line 639  sub phasetwo { Line 665  sub phasetwo {
      $metadatafields{'dependencies'}=$ENV{'form.dependencies'};       $metadatafields{'dependencies'}=$ENV{'form.dependencies'};
   
      my $allkeywords=$ENV{'form.addkey'};       my $allkeywords=$ENV{'form.addkey'};
      map {       foreach (keys %ENV) {
          if ($_=~/^form\.key\.(\w+)/) {           if ($_=~/^form\.key\.(\w+)/) {
      $allkeywords.=','.$1;       $allkeywords.=','.$1;
          }           }
      } keys %ENV;       }
      $allkeywords=~s/\W+/\,/;       $allkeywords=~s/\W+/\,/;
      $allkeywords=~s/^\,//;       $allkeywords=~s/^\,//;
      $metadatafields{'keywords'}=$allkeywords;       $metadatafields{'keywords'}=$allkeywords;
Line 654  sub phasetwo { Line 680  sub phasetwo {
        unless ($mfh=Apache::File->new('>'.$source.'.meta')) {         unless ($mfh=Apache::File->new('>'.$source.'.meta')) {
  return    return 
          '<font color=red>Could not write metadata, FAIL</font>';           '<font color=red>Could not write metadata, FAIL</font>';
        }             }
        map {         foreach (sort keys %metadatafields) {
  unless ($_=~/\./) {   unless ($_=~/\./) {
            my $unikey=$_;             my $unikey=$_;
            $unikey=~/^([A-Za-z]+)/;             $unikey=~/^([A-Za-z]+)/;
            my $tag=$1;             my $tag=$1;
            $tag=~tr/A-Z/a-z/;             $tag=~tr/A-Z/a-z/;
            print $mfh "\n\<$tag";             print $mfh "\n\<$tag";
            map {             foreach (split(/\,/,$metadatakeys{$unikey})) {
                my $value=$metadatafields{$unikey.'.'.$_};                 my $value=$metadatafields{$unikey.'.'.$_};
                $value=~s/\"/\'\'/g;                 $value=~s/\"/\'\'/g;
                print $mfh ' '.$_.'="'.$value.'"';                 print $mfh ' '.$_.'="'.$value.'"';
            } split(/\,/,$metadatakeys{$unikey});             }
    print $mfh '>'.$metadatafields{$unikey}.'</'.$tag.'>';     print $mfh '>'.$metadatafields{$unikey}.'</'.$tag.'>';
          }           }
        } sort keys %metadatafields;         }
        $scrout.='<p>Wrote Metadata';         $scrout.='<p>Wrote Metadata';
        print $logfile "\nWrote metadata";         print $logfile "\nWrote metadata";
      }       }
Line 695  sub phasetwo { Line 721  sub phasetwo {
   'delete from metadata where url like binary'.    'delete from metadata where url like binary'.
   '"'.$sqldatafields{'url'}.'"');    '"'.$sqldatafields{'url'}.'"');
     $sth->execute();      $sth->execute();
     map {my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g;       foreach ('title','author','subject','keywords','notes','abstract',
  $sqldatafields{$_}=$field;}  
     ('title','author','subject','keywords','notes','abstract',  
      'mime','language','creationdate','lastrevisiondate','owner',       'mime','language','creationdate','lastrevisiondate','owner',
      'copyright');       'copyright') {
    my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g; 
    $sqldatafields{$_}=$field;
       }
           
     $sth=$dbh->prepare('insert into metadata values ('.      $sth=$dbh->prepare('insert into metadata values ('.
        '"'.delete($sqldatafields{'title'}).'"'.','.         '"'.delete($sqldatafields{'title'}).'"'.','.
Line 910  sub handler { Line 937  sub handler {
   
 # Get query string for limited number of parameters  # Get query string for limited number of parameters
   
     map {      foreach (split(/&/,$ENV{'QUERY_STRING'})) {
        my ($name, $value) = split(/=/,$_);         my ($name, $value) = split(/=/,$_);
        $value =~ tr/+/ /;         $value =~ tr/+/ /;
        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
Line 919  sub handler { Line 946  sub handler {
               $ENV{'form.'.$name}=$value;                $ENV{'form.'.$name}=$value;
    }     }
        }         }
     } (split(/&/,$ENV{'QUERY_STRING'}));      }
   
   
 # -------------------------------------------------------------- Check filename  # -------------------------------------------------------------- Check filename
Line 994  unless ($ENV{'form.phase'} eq 'two') { Line 1021  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>;  
   }    }
   
 }  }
Line 1037  unless ($ENV{'form.phase'} eq 'two') { Line 1044  unless ($ENV{'form.phase'} eq 'two') {
   {    {
       $thisfn=~/\.(\w+)$/;        $thisfn=~/\.(\w+)$/;
       my $thistype=$1;        my $thistype=$1;
       my $thisembstyle=&Apache::lonnet::fileembstyle($thistype);        my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
   
       my $thistarget=$thisfn;        my $thistarget=$thisfn;
               
Line 1059  unless ($ENV{'form.phase'} eq 'two') { Line 1066  unless ($ENV{'form.phase'} eq 'two') {
                '</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>');     '&versionone=priv" target=cat>Diffs with Current Version</a><p>');
Removed from v.1.64  
changed lines
  Added in v.1.65

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