Annotation of loncom/publisher/lonpublisher.pm, revision 1.16

1.1       www         1: # The LearningOnline Network with CAPA
                      2: # Publication Handler
                      3: # 
                      4: # (TeX Content Handler
                      5: #
                      6: # 05/29/00,05/30,10/11 Gerd Kortemeyer)
                      7: #
1.15      www         8: # 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer
1.1       www         9: 
                     10: package Apache::lonpublisher;
                     11: 
                     12: use strict;
                     13: use Apache::File;
1.13      www        14: use File::Copy;
1.2       www        15: use Apache::Constants qw(:common :http :methods);
                     16: use HTML::TokeParser;
1.4       www        17: use Apache::lonxml;
1.10      www        18: use Apache::structuretags;
1.12      www        19: use Apache::inputtags;
1.10      www        20: use Apache::response;
1.2       www        21: 
1.3       www        22: my %addid;
1.5       www        23: my %nokey;
1.9       www        24: my %language;
1.10      www        25: my %cprtag;
                     26: 
1.7       www        27: my %metadatafields;
                     28: my %metadatakeys;
                     29: 
1.12      www        30: my $docroot;
                     31: 
                     32: # ----------------------------------------------- Evaluate string with metadata
                     33: 
1.7       www        34: sub metaeval {
                     35:     my $metastring=shift;
                     36:    
                     37:         my $parser=HTML::TokeParser->new(\$metastring);
                     38:         my $token;
                     39:         while ($token=$parser->get_token) {
                     40:            if ($token->[0] eq 'S') {
                     41: 	      my $entry=$token->[1];
                     42:               my $unikey=$entry;
                     43:               if (defined($token->[2]->{'part'})) { 
                     44:                  $unikey.='_'.$token->[2]->{'part'}; 
                     45: 	      }
                     46:               if (defined($token->[2]->{'name'})) { 
                     47:                  $unikey.='_'.$token->[2]->{'name'}; 
                     48: 	      }
                     49:                map {
                     50: 		  $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};
                     51:                   if ($metadatakeys{$unikey}) {
                     52: 		      $metadatakeys{$unikey}.=','.$_;
                     53:                   } else {
                     54:                       $metadatakeys{$unikey}=$_;
                     55:                   }
                     56:               } @{$token->[3]};
                     57:               if ($metadatafields{$unikey}) {
1.8       www        58: 		  my $newentry=$parser->get_text('/'.$entry);
                     59:                   unless ($metadatafields{$unikey}=~/$newentry/) {
                     60:                      $metadatafields{$unikey}.=', '.$newentry;
                     61: 		  }
1.7       www        62: 	      } else {
                     63:                  $metadatafields{$unikey}=$parser->get_text('/'.$entry);
                     64:               }
                     65:           }
                     66:        }
                     67: }
                     68: 
1.12      www        69: # -------------------------------------------------------- Read a metadata file
                     70: 
1.7       www        71: sub metaread {
                     72:     my ($logfile,$fn)=@_;
                     73:     unless (-e $fn) {
                     74: 	print $logfile 'No file '.$fn."\n";
                     75:         return '<br><b>No file:</b> <tt>'.$fn.'</tt>';
                     76:     }
                     77:     print $logfile 'Processing '.$fn."\n";
                     78:     my $metastring;
                     79:     {
                     80:      my $metafh=Apache::File->new($fn);
                     81:      $metastring=join('',<$metafh>);
                     82:     }
                     83:     &metaeval($metastring);
                     84:     return '<br><b>Processed file:</b> <tt>'.$fn.'</tt>';
                     85: }
                     86: 
1.12      www        87: # --------------------------------------------------------- Various form fields
                     88: 
1.8       www        89: sub textfield {
1.10      www        90:     my ($title,$name,$value)=@_;
1.8       www        91:     return "\n<p><b>$title:</b><br>".
1.11      www        92:            '<input type=text name="'.$name.'" size=80 value="'.$value.'">';
                     93: }
                     94: 
                     95: sub hiddenfield {
                     96:     my ($name,$value)=@_;
                     97:     return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">';
1.8       www        98: }
                     99: 
1.9       www       100: sub selectbox {
1.10      www       101:     my ($title,$name,$value,%options)=@_;
                    102:     my $selout="\n<p><b>$title:</b><br>".'<select name="'.$name.'">';
                    103:     map {
                    104:         $selout.='<option value="'.$_.'"';
                    105:         if ($_ eq $value) { $selout.=' selected'; }
                    106:         $selout.='>'.$options{$_}.'</option>';
                    107:     } sort keys %options;
                    108:     return $selout.'</select>';
1.9       www       109: }
                    110: 
1.12      www       111: # -------------------------------------------------------- Publication Step One
                    112: 
1.2       www       113: sub publish {
1.4       www       114: 
1.2       www       115:     my ($source,$target,$style)=@_;
                    116:     my $logfile;
1.4       www       117:     my $scrout='';
                    118: 
1.2       www       119:     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
1.7       www       120: 	return 
                    121:          '<font color=red>No write permission to user directory, FAIL</font>';
1.2       www       122:     }
                    123:     print $logfile 
1.11      www       124: "\n\n================= Publish ".localtime()." Phase One  ================\n";
1.2       www       125: 
1.3       www       126:     if (($style eq 'ssi') || ($style eq 'rat')) {
                    127: # ------------------------------------------------------- This needs processing
1.4       www       128: 
                    129: # ----------------------------------------------------------------- Backup Copy
1.3       www       130: 	my $copyfile=$source.'.save';
1.13      www       131:         if (copy($source,$copyfile)) {
1.3       www       132: 	    print $logfile "Copied original file to ".$copyfile."\n";
                    133:         } else {
1.13      www       134: 	    print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";
                    135:           return "<font color=red>Failed to write backup copy, $!,FAIL</font>";
1.3       www       136:         }
1.4       www       137: # ------------------------------------------------------------- IDs and indices
                    138: 
                    139:         my $maxindex=10;
                    140:         my $maxid=10;
                    141:         my $content='';
                    142:         my $needsfixup=0;
                    143: 
                    144:         {
                    145:           my $org=Apache::File->new($source);
                    146:           $content=join('',<$org>);
                    147:         }
                    148:         {
                    149:           my $parser=HTML::TokeParser->new(\$content);
                    150:           my $token;
                    151:           while ($token=$parser->get_token) {
                    152:               if ($token->[0] eq 'S') {
                    153:                   my $counter;
                    154: 		  if ($counter=$addid{$token->[1]}) {
                    155: 		      if ($counter eq 'id') {
                    156: 			  if (defined($token->[2]->{'id'})) {
                    157:                              $maxid=
                    158: 		       ($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
                    159: 			 } else {
                    160:                              $needsfixup=1;
                    161:                          }
                    162:                       } else {
                    163:  			  if (defined($token->[2]->{'index'})) {
                    164:                              $maxindex=
                    165: 	   ($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
                    166: 			  } else {
                    167:                              $needsfixup=1;
                    168: 			  }
                    169: 		      }
                    170: 		  }
                    171:               }
                    172:           }
                    173:       }
                    174:       if ($needsfixup) {
                    175:           print $logfile "Needs ID and/or index fixup\n".
                    176: 	        "Max ID   : $maxid (min 10)\n".
                    177:                 "Max Index: $maxindex (min 10)\n";
                    178: 
                    179:           my $outstring='';
                    180:           my $parser=HTML::TokeParser->new(\$content);
                    181:           my $token;
                    182:           while ($token=$parser->get_token) {
                    183:               if ($token->[0] eq 'S') {
                    184:                   my $counter;
                    185: 		  if ($counter=$addid{$token->[1]}) {
                    186: 		      if ($counter eq 'id') {
                    187: 			  if (defined($token->[2]->{'id'})) {
                    188: 			      $outstring.=$token->[4];
                    189: 			  } else {
                    190:                               $maxid++;
                    191:                               my $thisid=' id="'.$maxid.'"';
                    192: 			      my $fixup=$token->[4];
                    193:                               $fixup=~s/(\<\w+)/$1$thisid/;
                    194:                               $outstring.=$fixup;
                    195:                               print $logfile 'ID: '.$fixup."\n";
                    196:                           }
                    197:                       } else {
                    198:  			  if (defined($token->[2]->{'index'})) {
                    199: 			      $outstring.=$token->[4];
                    200: 			  } else {
                    201:                               $maxindex++;
                    202:                               my $thisindex=' index="'.$maxindex.'"';
                    203: 			      my $fixup=$token->[4];
                    204:                               $fixup=~s/(\<\w+)/$1$thisindex/;
                    205:                               $outstring.=$fixup;
                    206:                               print $logfile 'Index: '.$fixup."\n";
                    207: 			  }
                    208: 		      }
                    209: 		  } else {
                    210:                       $outstring.=$token->[4];
                    211:                   }
                    212:               } elsif ($token->[0] eq 'E') {
                    213:                   $outstring.=$token->[2];
                    214:               } else {
                    215:                   $outstring.=$token->[1];
                    216:               }
                    217:           }
                    218:         {
                    219:           my $org;
                    220:           unless ($org=Apache::File->new('>'.$source)) {
                    221:              print $logfile "No write permit to $source\n";
1.7       www       222:              return 
                    223:               "<font color=red>No write permission to $source, FAIL</font>";
1.4       www       224: 	  }
                    225:           print $org $outstring;
                    226:         }
                    227: 	  $content=$outstring;
                    228:           print $logfile "End of ID and/or index fixup\n".
                    229: 	        "Max ID   : $maxid (min 10)\n".
                    230:                 "Max Index: $maxindex (min 10)\n";
                    231:       } else {
                    232: 	  print $logfile "Does not need ID and/or index fixup\n";
                    233:       }
1.7       www       234: 
                    235: # --------------------------------------------- Initial step done, now metadata
                    236: 
                    237: # ---------------------------------------- Storage for metadata keys and fields
                    238: 
1.8       www       239:      %metadatafields=();
                    240:      %metadatakeys=();
                    241:      
                    242:      my %oldparmstores=();
1.7       www       243: 
                    244: # ------------------------------------------------ First, check out environment
1.8       www       245:      unless (-e $source.'.meta') {
1.7       www       246:         $metadatafields{'author'}=$ENV{'environment.firstname'}.' '.
                    247: 	                          $ENV{'environment.middlename'}.' '.
                    248: 		                  $ENV{'environment.lastname'}.' '.
                    249: 		                  $ENV{'environment.generation'};
1.8       www       250:         $metadatafields{'author'}=~s/\s+/ /g;
                    251:         $metadatafields{'author'}=~s/\s+$//;
1.10      www       252:         $metadatafields{'owner'}=$ENV{'user.name'}.'@'.$ENV{'user.domain'};
1.7       www       253: 
                    254: # ------------------------------------------------ Check out directory hierachy
                    255: 
                    256:         my $thisdisfn=$source;
                    257:         $thisdisfn=~s/^\/home\/$ENV{'user.name'}\///;
                    258: 
                    259:         my @urlparts=split(/\//,$thisdisfn);
                    260:         $#urlparts--;
                    261: 
                    262:         my $currentpath='/home/'.$ENV{'user.name'}.'/';
                    263: 
                    264:         map {
                    265: 	    $currentpath.=$_.'/';
                    266:             $scrout.=&metaread($logfile,$currentpath.'default.meta');
                    267:         } @urlparts;
                    268: 
                    269: # ------------------- Clear out parameters and stores (there should not be any)
                    270: 
                    271:         map {
                    272: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
                    273: 		delete $metadatafields{$_};
                    274:             }
                    275:         } keys %metadatafields;
                    276: 
1.8       www       277:     } else {
1.7       www       278: # ---------------------- Read previous metafile, remember parameters and stores
                    279: 
                    280:         $scrout.=&metaread($logfile,$source.'.meta');
                    281: 
                    282:         map {
                    283: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
                    284:                 $oldparmstores{$_}=1;
                    285: 		delete $metadatafields{$_};
                    286:             }
                    287:         } keys %metadatafields;
                    288:         
1.8       www       289:     }
1.7       www       290: 
1.4       www       291: # -------------------------------------------------- Parse content for metadata
                    292: 
1.10      www       293:         my $allmeta=Apache::lonxml::xmlparse('meta',$content);
1.7       www       294:         &metaeval($allmeta);
                    295: 
                    296: # ---------------- Find and document discrepancies in the parameters and stores
                    297: 
                    298:         my $chparms='';
                    299:         map {
                    300: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
                    301:                 unless ($_=~/\.\w+$/) { 
                    302:                    unless ($oldparmstores{$_}) {
                    303: 		      print $logfile 'New: '.$_."\n";
                    304:                       $chparms.=$_.' ';
                    305:                    }
                    306: 	        }
                    307:             }
                    308:         } sort keys %metadatafields;
                    309:         if ($chparms) {
                    310: 	    $scrout.='<p><b>New parameters or stored values:</b> '.
                    311:                      $chparms;
                    312:         }
                    313: 
                    314:         my $chparms='';
                    315:         map {
                    316: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
1.12      www       317:                 unless (($metadatafields{$_.'.name'}) || ($_=~/\.\w+$/)) {
1.7       www       318: 		    print $logfile 'Obsolete: '.$_."\n";
                    319:                     $chparms.=$_.' ';
                    320:                 }
                    321:             }
                    322:         } sort keys %oldparmstores;
                    323:         if ($chparms) {
                    324: 	    $scrout.='<p><b>Obsolete parameters or stored values:</b> '.
                    325:                      $chparms;
                    326:         }
1.5       www       327: 
1.8       www       328: # ------------------------------------------------------- Now have all metadata
1.5       www       329: 
1.8       www       330:         $scrout.=
                    331:      '<form action="/adm/publish" method="post">'.
1.11      www       332:           &hiddenfield('phase','two').
                    333:           &hiddenfield('filename',$ENV{'form.filename'}).
                    334: 	  &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).
1.10      www       335:           &textfield('Title','title',$metadatafields{'title'}).
                    336:           &textfield('Author(s)','author',$metadatafields{'author'}).
                    337: 	  &textfield('Subject','subject',$metadatafields{'subject'});
1.5       www       338: 
                    339: # --------------------------------------------------- Scan content for keywords
1.7       www       340: 
1.8       www       341: 	my $keywordout='<p><b>Keywords:</b><br><table border=2><tr>';
1.7       www       342:         my $colcount=0;
                    343:         
1.5       www       344: 	{
                    345: 	    my $textonly=$content;
                    346:             $textonly=~s/\<script[^\<]+\<\/script\>//g;
                    347:             $textonly=~s/\<m\>[^\<]+\<\/m\>//g;
                    348:             $textonly=~s/\<[^\>]*\>//g;
                    349:             $textonly=~tr/A-Z/a-z/;
                    350:             $textonly=~s/[\$\&][a-z]\w*//g;
                    351:             $textonly=~s/[^a-z\s]//g;
                    352: 
                    353:             my %keywords=();
                    354:             map {
                    355: 		unless ($nokey{$_}) {
                    356:                    $keywords{$_}=1;
                    357:                 } 
                    358:             } ($textonly=~m/(\w+)/g);
                    359: 
1.12      www       360:             map {
                    361: 		$keywords{$_}=1;
                    362:             } split(/\W+/,$metadatafields{'keywords'});
1.5       www       363: 
1.7       www       364:             map {
1.12      www       365:                 $keywordout.='<td><input type=checkbox name="key.'.$_.'"';
1.8       www       366:                 if ($metadatafields{'keywords'}=~/$_/) { 
                    367:                    $keywordout.=' checked'; 
                    368:                 }
                    369:                 $keywordout.='>'.$_.'</td>';
1.7       www       370:                 if ($colcount>10) {
                    371: 		    $keywordout.="</tr><tr>\n";
                    372:                     $colcount=0;
                    373:                 }
                    374:                 $colcount++;
                    375:             } sort keys %keywords;
                    376:             $keywordout.='</tr></table>';
1.5       www       377: 
                    378:         }         
1.4       www       379:         
1.7       www       380: 	$scrout.=$keywordout;
1.9       www       381: 
1.12      www       382:         $scrout.=&textfield('Additional Keywords','addkey','');
                    383: 
1.10      www       384:         $scrout.=&textfield('Notes','notes',$metadatafields{'notes'});
1.9       www       385: 
                    386:         $scrout.=
                    387:              '<p><b>Abstract:</b><br><textarea cols=80 rows=5 name=abstract>'.
                    388:               $metadatafields{'abstract'}.'</textarea>';
                    389: 
1.11      www       390: 	$source=~/\.(\w+)$/;
                    391: 
                    392: 	$scrout.=&hiddenfield('mime',$1);
                    393: 
1.10      www       394:         $scrout.=&selectbox('Language','language',
                    395:                             $metadatafields{'language'},%language);
1.11      www       396: 
                    397:         unless ($metadatafields{'creationdate'}) {
                    398: 	    $metadatafields{'creationdate'}=time;
                    399:         }
                    400:         $scrout.=&hiddenfield('creationdate',$metadatafields{'creationdate'});
                    401: 
                    402:         $scrout.=&hiddenfield('lastrevisiondate',time);
                    403: 
1.9       www       404: 			   
1.10      www       405: 	$scrout.=&textfield('Publisher/Owner','owner',
                    406:                             $metadatafields{'owner'});
                    407: 
                    408:         $scrout.=&selectbox('Copyright/Distribution','copyright',
                    409:                             $metadatafields{'copyright'},%cprtag);
1.9       www       410: 
1.3       www       411:     }
1.8       www       412:     return $scrout.
                    413:       '<p><input type="submit" value="Finalize Publication"></form>';
1.2       www       414: }
1.1       www       415: 
1.12      www       416: # -------------------------------------------------------- Publication Step Two
                    417: 
1.11      www       418: sub phasetwo {
                    419: 
                    420:     my ($source,$target,$style)=@_;
                    421:     my $logfile;
                    422:     my $scrout='';
                    423: 
                    424:     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
                    425: 	return 
                    426:          '<font color=red>No write permission to user directory, FAIL</font>';
                    427:     }
                    428:     print $logfile 
                    429: "\n================= Publish ".localtime()." Phase Two  ================\n";
                    430: 
                    431:      %metadatafields=();
                    432:      %metadatakeys=();
                    433: 
                    434:      &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'}));
                    435: 
                    436:      $metadatafields{'title'}=$ENV{'form.title'};
                    437:      $metadatafields{'author'}=$ENV{'form.author'};
                    438:      $metadatafields{'subject'}=$ENV{'form.subject'};
                    439:      $metadatafields{'notes'}=$ENV{'form.notes'};
                    440:      $metadatafields{'abstract'}=$ENV{'form.abstract'};
                    441:      $metadatafields{'mime'}=$ENV{'form.mime'};
                    442:      $metadatafields{'language'}=$ENV{'form.language'};
                    443:      $metadatafields{'creationdate'}=$ENV{'form.creationdate'};
                    444:      $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'};
                    445:      $metadatafields{'owner'}=$ENV{'form.owner'};
                    446:      $metadatafields{'copyright'}=$ENV{'form.copyright'};
1.12      www       447: 
                    448:      my $allkeywords=$ENV{'form.addkey'};
1.11      www       449:      map {
1.12      www       450:          if ($_=~/^form\.key\.(\w+)/) {
                    451: 	     $allkeywords.=','.$1;
                    452:          }
                    453:      } keys %ENV;
                    454:      $allkeywords=~s/\W+/\,/;
                    455:      $allkeywords=~s/^\,//;
                    456:      $metadatafields{'keywords'}=$allkeywords;
                    457:  
                    458:      {
                    459:        print $logfile "\nWrite metadata file for ".$source;
                    460:        my $mfh;
                    461:        unless ($mfh=Apache::File->new('>'.$source.'.meta')) {
                    462: 	return 
                    463:          '<font color=red>Could not write metadata, FAIL</font>';
                    464:        }    
                    465:        map {
                    466: 	 unless ($_=~/\./) {
                    467:            my $unikey=$_;
                    468:            $unikey=~/^([A-Za-z]+)/;
                    469:            my $tag=$1;
                    470:            $tag=~tr/A-Z/a-z/;
                    471:            print $mfh "\n\<$tag";
                    472:            map {
                    473:                my $value=$metadatafields{$unikey.'.'.$_};
                    474:                $value=~s/\"/\'\'/g;
                    475:                print $mfh ' '.$_.'="'.$value.'"';
                    476:            } split(/\,/,$metadatakeys{$unikey});
                    477: 	   print $mfh '>'.$metadatafields{$unikey}.'</'.$tag.'>';
                    478:          }
                    479:        } sort keys %metadatafields;
                    480:        $scrout.='<p>Wrote Metadata';
                    481:        print $logfile "\nWrote metadata";
                    482:      }
                    483: 
                    484: # ----------------------------------------------------------- Copy old versions
                    485:    
                    486: if (-e $target) {
                    487:     my $filename;
                    488:     my $maxversion=0;
                    489:     $target=~/(.*)\/([^\/]+)\.(\w+)$/;
                    490:     my $srcf=$2;
                    491:     my $srct=$3;
                    492:     my $srcd=$1;
                    493:     unless ($srcd=~/^\/home\/httpd\/html\/res/) {
                    494: 	print $logfile "\nPANIC: Target dir is ".$srcd;
                    495:         return "<font color=red>Invalid target directory, FAIL</font>";
                    496:     }
                    497:     opendir(DIR,$srcd);
                    498:     while ($filename=readdir(DIR)) {
                    499:        if ($filename=~/$srcf\.(\d+)\.$srct$/) {
                    500: 	   $maxversion=($1>$maxversion)?$1:$maxversion;
                    501:        }
                    502:     }
                    503:     closedir(DIR);
                    504:     $maxversion++;
                    505:     $scrout.='<p>Creating old version '.$maxversion;
                    506:     print $logfile "\nCreating old version ".$maxversion;
                    507: 
                    508:     my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct;
                    509: 
1.13      www       510:         if (copy($target,$copyfile)) {
1.12      www       511: 	    print $logfile "Copied old target to ".$copyfile."\n";
                    512:             $scrout.='<p>Copied old target file';
                    513:         } else {
1.13      www       514: 	    print $logfile "Unable to write ".$copyfile.':'.$!."\n";
                    515:            return "<font color=red>Failed to copy old target, $!, FAIL</font>";
1.12      www       516:         }
                    517: 
                    518: # --------------------------------------------------------------- Copy Metadata
                    519: 
                    520: 	$copyfile=$copyfile.'.meta';
1.13      www       521: 
                    522:         if (copy($target.'.meta',$copyfile)) {
1.14      www       523: 	    print $logfile "Copied old target metadata to ".$copyfile."\n";
1.12      www       524:             $scrout.='<p>Copied old metadata';
                    525:         } else {
1.13      www       526: 	    print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n";
1.14      www       527:             if (-e $target.'.meta') {
                    528:                return 
1.13      www       529:        "<font color=red>Failed to write old metadata copy, $!, FAIL</font>";
1.14      www       530: 	    }
1.12      www       531:         }
1.11      www       532: 
                    533: 
1.12      www       534: } else {
                    535:     $scrout.='<p>Initial version';
                    536:     print $logfile "\nInitial version";
                    537: }
                    538: 
                    539: # ---------------------------------------------------------------- Write Source
                    540: 	my $copyfile=$target;
                    541: 
                    542:            my @parts=split(/\//,$copyfile);
                    543:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
                    544: 
                    545:            my $count;
                    546:            for ($count=5;$count<$#parts;$count++) {
                    547:                $path.="/$parts[$count]";
                    548:                if ((-e $path)!=1) {
                    549:                    print $logfile "\nCreating directory ".$path;
                    550:                    $scrout.='<p>Created directory '.$parts[$count];
                    551: 		   mkdir($path,0777);
                    552:                }
                    553:            }
                    554: 
1.13      www       555:         if (copy($source,$copyfile)) {
1.12      www       556: 	    print $logfile "Copied original source to ".$copyfile."\n";
                    557:             $scrout.='<p>Copied source file';
                    558:         } else {
1.13      www       559: 	    print $logfile "Unable to write ".$copyfile.':'.$!."\n";
                    560:             return "<font color=red>Failed to copy source, $!, FAIL</font>";
1.12      www       561:         }
                    562: 
                    563: # --------------------------------------------------------------- Copy Metadata
                    564: 
1.13      www       565:         $copyfile=$copyfile.'.meta';
                    566: 
                    567:         if (copy($source.'.meta',$copyfile)) {
1.12      www       568: 	    print $logfile "Copied original metadata to ".$copyfile."\n";
                    569:             $scrout.='<p>Copied metadata';
                    570:         } else {
1.13      www       571: 	    print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n";
1.12      www       572:             return 
1.13      www       573:           "<font color=red>Failed to write metadata copy, $!, FAIL</font>";
1.12      www       574:         }
                    575: 
                    576: # --------------------------------------------------- Send update notifications
                    577: 
                    578: {
                    579: 
                    580:     my $filename;
                    581:  
                    582:     $target=~/(.*)\/([^\/]+)$/;
                    583:     my $srcf=$2;
                    584:     opendir(DIR,$1);
                    585:     while ($filename=readdir(DIR)) {
                    586:        if ($filename=~/$srcf\.(\w+)$/) {
                    587: 	   my $subhost=$1;
                    588:            if ($subhost ne 'meta') {
                    589: 	       $scrout.='<p>Notifying host '.$subhost.':';
                    590:                print $logfile "\nNotifying host '.$subhost.':'";
                    591:                my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);
                    592:                $scrout.=$reply;
                    593:                print $logfile $reply;              
                    594:            }
                    595:        }
                    596:     }
                    597:     closedir(DIR);
                    598: 
                    599: }
                    600: 
                    601: # ------------------------------------------------ Provide link to new resource
                    602: 
                    603:     my $thisdistarget=$target;
                    604:     $thisdistarget=~s/^$docroot//;
                    605: 
                    606:     return $scrout.
                    607: 	'<p><a href="'.$thisdistarget.'"><font size=+2>View Target</font></a>';
1.11      www       608: }
                    609: 
1.1       www       610: # ================================================================ Main Handler
                    611: 
                    612: sub handler {
                    613:   my $r=shift;
1.2       www       614: 
                    615:   if ($r->header_only) {
                    616:      $r->content_type('text/html');
                    617:      $r->send_http_header;
                    618:      return OK;
                    619:   }
                    620: 
1.15      www       621: unless ($ENV{'form.pubdir'}) {
1.2       www       622: # -------------------------------------------------------------- Check filename
                    623: 
                    624:   my $fn=$ENV{'form.filename'};
                    625: 
                    626:   unless ($fn) { 
                    627:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    628:          ' trying to publish empty filename', $r->filename); 
                    629:      return HTTP_NOT_FOUND;
                    630:   } 
1.4       www       631: 
                    632:   unless ($ENV{'user.home'} eq $r->dir_config('lonHostID')) {
                    633:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    634:          ' trying to publish file '.$ENV{'form.filename'}.
                    635:          ' ('.$fn.') - not homeserver ('.$ENV{'user.home'}.')', 
                    636:          $r->filename); 
                    637:      return HTTP_NOT_ACCEPTABLE;
                    638:   }
1.2       www       639: 
                    640:   $fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/;
                    641: 
                    642:   my $targetdir='';
1.12      www       643:   $docroot=$r->dir_config('lonDocRoot'); 
1.2       www       644:   if ($1 ne $ENV{'user.name'}) {
                    645:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    646:          ' trying to publish unowned file '.$ENV{'form.filename'}.
                    647:          ' ('.$fn.')', 
                    648:          $r->filename); 
                    649:      return HTTP_NOT_ACCEPTABLE;
                    650:   } else {
                    651:       $targetdir=$docroot.'/res/'.$ENV{'user.domain'};
                    652:   }
                    653:                                  
                    654:   
                    655:   unless (-e $fn) { 
                    656:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    657:          ' trying to publish non-existing file '.$ENV{'form.filename'}.
                    658:          ' ('.$fn.')', 
                    659:          $r->filename); 
                    660:      return HTTP_NOT_FOUND;
                    661:   } 
                    662: 
1.11      www       663: unless ($ENV{'form.phase'} eq 'two') {
                    664: 
1.2       www       665: # --------------------------------- File is there and owned, init lookup tables
                    666: 
1.3       www       667:   %addid=();
                    668: 
                    669:   {
                    670:       my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab');
                    671:       while (<$fh>=~/(\w+)\s+(\w+)/) {
                    672:           $addid{$1}=$2;
                    673:       }
1.5       www       674:   }
                    675: 
                    676:   %nokey=();
                    677: 
                    678:   {
                    679:      my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab');
                    680:       map {
                    681:           my $word=$_;
                    682:           chomp($word);
                    683:           $nokey{$word}=1;
1.9       www       684:       } <$fh>;
                    685:   }
                    686: 
                    687:   %language=();
                    688: 
                    689:   {
                    690:      my $fh=Apache::File->new($r->dir_config('lonTabDir').'/language.tab');
                    691:       map {
1.10      www       692:           $_=~/(\w+)\s+([\w\s\-]+)/;
1.9       www       693:           $language{$1}=$2;
1.10      www       694:       } <$fh>;
                    695:   }
                    696: 
                    697:   %cprtag=();
                    698: 
                    699:   {
                    700:      my $fh=Apache::File->new($r->dir_config('lonIncludes').'/copyright.tab');
                    701:       map {
                    702:           $_=~/(\w+)\s+([\w\s\-]+)/;
                    703:           $cprtag{$1}=$2;
1.5       www       704:       } <$fh>;
1.3       www       705:   }
1.11      www       706: 
                    707: }
                    708: 
1.2       www       709: # ----------------------------------------------------------- Start page output
                    710: 
1.1       www       711:   $r->content_type('text/html');
                    712:   $r->send_http_header;
                    713: 
                    714:   $r->print('<html><head><title>LON-CAPA Publishing</title></head>');
1.15      www       715:   $r->print(
                    716:    '<body bgcolor="#FFFFFF"><img align=right src=/adm/lonIcons/lonlogos.gif>');
1.2       www       717:   my $thisfn=$fn;
                    718:    
                    719: # ------------------------------------------------------------- Individual file
                    720:   {
                    721:       $thisfn=~/\.(\w+)$/;
                    722:       my $thistype=$1;
                    723:       my $thisembstyle=&Apache::lonnet::fileembstyle($thistype);
                    724: 
                    725:       my $thistarget=$thisfn;
                    726:       
                    727:       $thistarget=~s/^\/home/$targetdir/;
                    728:       $thistarget=~s/\/public\_html//;
                    729: 
                    730:       my $thisdistarget=$thistarget;
                    731:       $thisdistarget=~s/^$docroot//;
                    732: 
                    733:       my $thisdisfn=$thisfn;
                    734:       $thisdisfn=~s/^\/home\/$ENV{'user.name'}\/public_html\///;
                    735: 
                    736:       $r->print('<h2>Publishing '.
                    737:         &Apache::lonnet::filedescription($thistype).' <tt>'.
                    738:         $thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>');
1.11      www       739:   
1.2       www       740: # ------------ We are publishing from $thisfn to $thistarget with $thisembstyle
                    741: 
1.11      www       742:        unless ($ENV{'form.phase'} eq 'two') {
                    743:           $r->print('<hr>'.&publish($thisfn,$thistarget,$thisembstyle));
                    744:        } else {
                    745:           $r->print('<hr>'.&phasetwo($thisfn,$thistarget,$thisembstyle));      
                    746:        }  
1.2       www       747: 
1.11      www       748:   }
1.1       www       749:   $r->print('</body></html>');
1.15      www       750: } else {
                    751: 
                    752:   my $fn=$ENV{'form.filename'};
                    753: 
                    754:   $fn=~s/\/[^\/]+$//;
                    755:   my $thisprefix=$fn;
                    756:   $thisprefix=~s/\/\~/\/priv\//;
                    757: 
                    758:   $fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/;
                    759: 
                    760:   unless ($fn) { 
                    761:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    762:          ' trying to publish empty directory', $r->filename); 
                    763:      return HTTP_NOT_FOUND;
                    764:   } 
                    765: 
                    766: # ----------------------------------------------------------- Start page output
1.1       www       767: 
1.15      www       768:   $r->content_type('text/html');
                    769:   $r->send_http_header;
                    770: 
                    771:   $r->print('<html><head><title>LON-CAPA Publishing Directory</title></head>');
                    772:   $r->print(
                    773:    '<body bgcolor="#FFFFFF"><img align=right src=/adm/lonIcons/lonlogos.gif>');
                    774: 
                    775:   my $thisdisfn=$fn;
                    776:   $thisdisfn=~s/^\/home\/$ENV{'user.name'}\/public_html\///;
                    777:   
                    778:   $r->print('<h1>Publishing directory <tt>'.$thisdisfn.'</tt></h1>');
                    779:   my $i=0;
                    780:   $r->print('<script>');
                    781:     my $filename;
                    782:     opendir(DIR,$fn);
                    783:        while ($filename=readdir(DIR)) {
                    784:            $filename=~/\.(\w+)$/;
                    785:            if ((&Apache::lonnet::fileembstyle($1)) && ($1 ne 'meta')) {
                    786: 	      $r->print(<<ENDOPEN);
                    787: 	      pub$i=window.open("$thisprefix/$filename","LONCAPApub$i",
                    788:                                 "menubar=no,height=450,width=650");
                    789: ENDOPEN
                    790:               $i++;     
                    791: 	   }
                    792:        }
                    793:     closedir(DIR);
                    794:   $r->print('</script>');
                    795: 
                    796:   $r->print('</body></html>');
                    797:   
                    798: }
1.1       www       799:   return OK;
                    800: }
                    801: 
                    802: 1;
                    803: __END__
                    804: 
                    805: 
                    806: 
                    807: 
                    808: 
                    809: 
                    810: 

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