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

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.8       www         8: # 11/28,11/29,11/30,12/01 Gerd Kortemeyer
1.1       www         9: 
                     10: package Apache::lonpublisher;
                     11: 
                     12: use strict;
                     13: use Apache::File;
1.2       www        14: use Apache::Constants qw(:common :http :methods);
                     15: use HTML::TokeParser;
1.4       www        16: use Apache::lonxml;
1.6       www        17: use Apache::lonhomework;
1.2       www        18: 
1.3       www        19: my %addid;
1.5       www        20: my %nokey;
1.9     ! www        21: my %language;
1.7       www        22: my %metadatafields;
                     23: my %metadatakeys;
                     24: 
                     25: sub metaeval {
                     26:     my $metastring=shift;
                     27:    
                     28:         my $parser=HTML::TokeParser->new(\$metastring);
                     29:         my $token;
                     30:         while ($token=$parser->get_token) {
                     31:            if ($token->[0] eq 'S') {
                     32: 	      my $entry=$token->[1];
                     33:               my $unikey=$entry;
                     34:               if (defined($token->[2]->{'part'})) { 
                     35:                  $unikey.='_'.$token->[2]->{'part'}; 
                     36: 	      }
                     37:               if (defined($token->[2]->{'name'})) { 
                     38:                  $unikey.='_'.$token->[2]->{'name'}; 
                     39: 	      }
                     40:                map {
                     41: 		  $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};
                     42:                   if ($metadatakeys{$unikey}) {
                     43: 		      $metadatakeys{$unikey}.=','.$_;
                     44:                   } else {
                     45:                       $metadatakeys{$unikey}=$_;
                     46:                   }
                     47:               } @{$token->[3]};
                     48:               if ($metadatafields{$unikey}) {
1.8       www        49: 		  my $newentry=$parser->get_text('/'.$entry);
                     50:                   unless ($metadatafields{$unikey}=~/$newentry/) {
                     51:                      $metadatafields{$unikey}.=', '.$newentry;
                     52: 		  }
1.7       www        53: 	      } else {
                     54:                  $metadatafields{$unikey}=$parser->get_text('/'.$entry);
                     55:               }
                     56:           }
                     57:        }
                     58: }
                     59: 
                     60: sub metaread {
                     61:     my ($logfile,$fn)=@_;
                     62:     unless (-e $fn) {
                     63: 	print $logfile 'No file '.$fn."\n";
                     64:         return '<br><b>No file:</b> <tt>'.$fn.'</tt>';
                     65:     }
                     66:     print $logfile 'Processing '.$fn."\n";
                     67:     my $metastring;
                     68:     {
                     69:      my $metafh=Apache::File->new($fn);
                     70:      $metastring=join('',<$metafh>);
                     71:     }
                     72:     &metaeval($metastring);
                     73:     return '<br><b>Processed file:</b> <tt>'.$fn.'</tt>';
                     74: }
                     75: 
1.8       www        76: sub textfield {
                     77:     my ($title,$value)=@_;
                     78:     return "\n<p><b>$title:</b><br>".
                     79:            '<input type=text size=80 value="'.$value.'">';
                     80: }
                     81: 
1.9     ! www        82: sub selectbox {
        !            83:     my ($title,$value,%options)=@_;
        !            84: }
        !            85: 
1.2       www        86: sub publish {
1.4       www        87: 
1.2       www        88:     my ($source,$target,$style)=@_;
                     89:     my $logfile;
1.4       www        90:     my $scrout='';
                     91: 
1.2       www        92:     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
1.7       www        93: 	return 
                     94:          '<font color=red>No write permission to user directory, FAIL</font>';
1.2       www        95:     }
                     96:     print $logfile 
                     97: "\n\n================== Publish ".localtime()." =================\n";
                     98: 
1.3       www        99:     if (($style eq 'ssi') || ($style eq 'rat')) {
                    100: # ------------------------------------------------------- This needs processing
1.4       www       101: 
                    102: # ----------------------------------------------------------------- Backup Copy
1.3       www       103: 	my $copyfile=$source.'.save';
                    104:         {
                    105: 	    my $org=Apache::File->new($source);
                    106:             my $cop=Apache::File->new('>'.$copyfile);
                    107:             while (my $line=<$org>) { print $cop $line; }
                    108:         }
                    109:         if (-e $copyfile) {
                    110: 	    print $logfile "Copied original file to ".$copyfile."\n";
                    111:         } else {
1.4       www       112: 	    print $logfile "Unable to write backup ".$copyfile."\n";
1.7       www       113:             return "<font color=red>Failed to write backup copy, FAIL</font>";
1.3       www       114:         }
1.4       www       115: # ------------------------------------------------------------- IDs and indices
                    116: 
                    117:         my $maxindex=10;
                    118:         my $maxid=10;
                    119:         my $content='';
                    120:         my $needsfixup=0;
                    121: 
                    122:         {
                    123:           my $org=Apache::File->new($source);
                    124:           $content=join('',<$org>);
                    125:         }
                    126:         {
                    127:           my $parser=HTML::TokeParser->new(\$content);
                    128:           my $token;
                    129:           while ($token=$parser->get_token) {
                    130:               if ($token->[0] eq 'S') {
                    131:                   my $counter;
                    132: 		  if ($counter=$addid{$token->[1]}) {
                    133: 		      if ($counter eq 'id') {
                    134: 			  if (defined($token->[2]->{'id'})) {
                    135:                              $maxid=
                    136: 		       ($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
                    137: 			 } else {
                    138:                              $needsfixup=1;
                    139:                          }
                    140:                       } else {
                    141:  			  if (defined($token->[2]->{'index'})) {
                    142:                              $maxindex=
                    143: 	   ($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
                    144: 			  } else {
                    145:                              $needsfixup=1;
                    146: 			  }
                    147: 		      }
                    148: 		  }
                    149:               }
                    150:           }
                    151:       }
                    152:       if ($needsfixup) {
                    153:           print $logfile "Needs ID and/or index fixup\n".
                    154: 	        "Max ID   : $maxid (min 10)\n".
                    155:                 "Max Index: $maxindex (min 10)\n";
                    156: 
                    157:           my $outstring='';
                    158:           my $parser=HTML::TokeParser->new(\$content);
                    159:           my $token;
                    160:           while ($token=$parser->get_token) {
                    161:               if ($token->[0] eq 'S') {
                    162:                   my $counter;
                    163: 		  if ($counter=$addid{$token->[1]}) {
                    164: 		      if ($counter eq 'id') {
                    165: 			  if (defined($token->[2]->{'id'})) {
                    166: 			      $outstring.=$token->[4];
                    167: 			  } else {
                    168:                               $maxid++;
                    169:                               my $thisid=' id="'.$maxid.'"';
                    170: 			      my $fixup=$token->[4];
                    171:                               $fixup=~s/(\<\w+)/$1$thisid/;
                    172:                               $outstring.=$fixup;
                    173:                               print $logfile 'ID: '.$fixup."\n";
                    174:                           }
                    175:                       } else {
                    176:  			  if (defined($token->[2]->{'index'})) {
                    177: 			      $outstring.=$token->[4];
                    178: 			  } else {
                    179:                               $maxindex++;
                    180:                               my $thisindex=' index="'.$maxindex.'"';
                    181: 			      my $fixup=$token->[4];
                    182:                               $fixup=~s/(\<\w+)/$1$thisindex/;
                    183:                               $outstring.=$fixup;
                    184:                               print $logfile 'Index: '.$fixup."\n";
                    185: 			  }
                    186: 		      }
                    187: 		  } else {
                    188:                       $outstring.=$token->[4];
                    189:                   }
                    190:               } elsif ($token->[0] eq 'E') {
                    191:                   $outstring.=$token->[2];
                    192:               } else {
                    193:                   $outstring.=$token->[1];
                    194:               }
                    195:           }
                    196:         {
                    197:           my $org;
                    198:           unless ($org=Apache::File->new('>'.$source)) {
                    199:              print $logfile "No write permit to $source\n";
1.7       www       200:              return 
                    201:               "<font color=red>No write permission to $source, FAIL</font>";
1.4       www       202: 	  }
                    203:           print $org $outstring;
                    204:         }
                    205: 	  $content=$outstring;
                    206:           print $logfile "End of ID and/or index fixup\n".
                    207: 	        "Max ID   : $maxid (min 10)\n".
                    208:                 "Max Index: $maxindex (min 10)\n";
                    209:       } else {
                    210: 	  print $logfile "Does not need ID and/or index fixup\n";
                    211:       }
1.7       www       212: 
                    213: # --------------------------------------------- Initial step done, now metadata
                    214: 
                    215: # ---------------------------------------- Storage for metadata keys and fields
                    216: 
1.8       www       217:      %metadatafields=();
                    218:      %metadatakeys=();
                    219:      
                    220:      my %oldparmstores=();
1.7       www       221: 
                    222: # ------------------------------------------------ First, check out environment
1.8       www       223:      unless (-e $source.'.meta') {
1.7       www       224:         $metadatafields{'author'}=$ENV{'environment.firstname'}.' '.
                    225: 	                          $ENV{'environment.middlename'}.' '.
                    226: 		                  $ENV{'environment.lastname'}.' '.
                    227: 		                  $ENV{'environment.generation'};
1.8       www       228:         $metadatafields{'author'}=~s/\s+/ /g;
                    229:         $metadatafields{'author'}=~s/\s+$//;
1.7       www       230: 
                    231: # ------------------------------------------------ Check out directory hierachy
                    232: 
                    233:         my $thisdisfn=$source;
                    234:         $thisdisfn=~s/^\/home\/$ENV{'user.name'}\///;
                    235: 
                    236:         my @urlparts=split(/\//,$thisdisfn);
                    237:         $#urlparts--;
                    238: 
                    239:         my $currentpath='/home/'.$ENV{'user.name'}.'/';
                    240: 
                    241:         map {
                    242: 	    $currentpath.=$_.'/';
                    243:             $scrout.=&metaread($logfile,$currentpath.'default.meta');
                    244:         } @urlparts;
                    245: 
                    246: # ------------------- Clear out parameters and stores (there should not be any)
                    247: 
                    248:         map {
                    249: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
                    250: 		delete $metadatafields{$_};
                    251:             }
                    252:         } keys %metadatafields;
                    253: 
1.8       www       254:     } else {
1.7       www       255: # ---------------------- Read previous metafile, remember parameters and stores
                    256: 
                    257:         $scrout.=&metaread($logfile,$source.'.meta');
                    258: 
                    259:         map {
                    260: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
                    261:                 $oldparmstores{$_}=1;
                    262: 		delete $metadatafields{$_};
                    263:             }
                    264:         } keys %metadatafields;
                    265:         
1.8       www       266:     }
1.7       www       267: 
1.4       www       268: # -------------------------------------------------- Parse content for metadata
                    269: 
1.6       www       270: 	my $allmeta='';
                    271:         if ($source=~/\.problem$/) {
                    272: 	    $allmeta=Apache::lonhomework::subhandler('meta',$content);
                    273:         } else {
                    274:             $allmeta=Apache::lonxml::xmlparse('meta',$content);
                    275: 	}
1.7       www       276:         &metaeval($allmeta);
                    277: 
                    278: # ---------------- Find and document discrepancies in the parameters and stores
                    279: 
                    280:         my $chparms='';
                    281:         map {
                    282: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
                    283:                 unless ($_=~/\.\w+$/) { 
                    284:                    unless ($oldparmstores{$_}) {
                    285: 		      print $logfile 'New: '.$_."\n";
                    286:                       $chparms.=$_.' ';
                    287:                    }
                    288: 	        }
                    289:             }
                    290:         } sort keys %metadatafields;
                    291:         if ($chparms) {
                    292: 	    $scrout.='<p><b>New parameters or stored values:</b> '.
                    293:                      $chparms;
                    294:         }
                    295: 
                    296:         my $chparms='';
                    297:         map {
                    298: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
                    299:                 unless (($metadatafields{$_}) || ($_=~/\.\w+$/)) {
                    300: 		    print $logfile 'Obsolete: '.$_."\n";
                    301:                     $chparms.=$_.' ';
                    302:                 }
                    303:             }
                    304:         } sort keys %oldparmstores;
                    305:         if ($chparms) {
                    306: 	    $scrout.='<p><b>Obsolete parameters or stored values:</b> '.
                    307:                      $chparms;
                    308:         }
1.5       www       309: 
1.8       www       310: # ------------------------------------------------------- Now have all metadata
1.5       www       311: 
1.8       www       312:         $scrout.=
                    313:      '<form action="/adm/publish" method="post">'.
                    314:      '<input type="hidden" name="phase" value="two">'.
                    315:      '<input type="hidden" name="filename" value="'.$ENV{'form.filename'}.'">'.
                    316:           &textfield('Title',$metadatafields{'title'}).
                    317:           &textfield('Author(s)',$metadatafields{'author'}).
                    318: 	  &textfield('Subject',$metadatafields{'subject'});
1.5       www       319: 
                    320: # --------------------------------------------------- Scan content for keywords
1.7       www       321: 
1.8       www       322: 	my $keywordout='<p><b>Keywords:</b><br><table border=2><tr>';
1.7       www       323:         my $colcount=0;
                    324:         
1.5       www       325: 	{
                    326: 	    my $textonly=$content;
                    327:             $textonly=~s/\<script[^\<]+\<\/script\>//g;
                    328:             $textonly=~s/\<m\>[^\<]+\<\/m\>//g;
                    329:             $textonly=~s/\<[^\>]*\>//g;
                    330:             $textonly=~tr/A-Z/a-z/;
                    331:             $textonly=~s/[\$\&][a-z]\w*//g;
                    332:             $textonly=~s/[^a-z\s]//g;
                    333: 
                    334:             my %keywords=();
                    335:             map {
                    336: 		unless ($nokey{$_}) {
                    337:                    $keywords{$_}=1;
                    338:                 } 
                    339:             } ($textonly=~m/(\w+)/g);
                    340: 
                    341: 
1.7       www       342:             map {
1.8       www       343:                 $keywordout.='<td><input type=checkbox name="'.$_.'"';
                    344:                 if ($metadatafields{'keywords'}=~/$_/) { 
                    345:                    $keywordout.=' checked'; 
                    346:                 }
                    347:                 $keywordout.='>'.$_.'</td>';
1.7       www       348:                 if ($colcount>10) {
                    349: 		    $keywordout.="</tr><tr>\n";
                    350:                     $colcount=0;
                    351:                 }
                    352:                 $colcount++;
                    353:             } sort keys %keywords;
                    354:             $keywordout.='</tr></table>';
1.5       www       355: 
                    356:         }         
1.4       www       357:         
1.7       www       358: 	$scrout.=$keywordout;
1.9     ! www       359: 
        !           360:         $scrout.=&textfield('Notes',$metadatafields{'notes'});
        !           361: 
        !           362:         $scrout.=
        !           363:              '<p><b>Abstract:</b><br><textarea cols=80 rows=5 name=abstract>'.
        !           364:               $metadatafields{'abstract'}.'</textarea>';
        !           365: 
        !           366:         $scrout.=&selectbox('Language',$metadatafields{'language'},%language);
        !           367: 			   
        !           368: 	$scrout.=&textfield('Publisher/Owner',$metadatafields{'owner'});
        !           369: 
1.3       www       370:     }
1.8       www       371:     return $scrout.
                    372:       '<p><input type="submit" value="Finalize Publication"></form>';
1.2       www       373: }
1.1       www       374: 
                    375: # ================================================================ Main Handler
                    376: 
                    377: sub handler {
                    378:   my $r=shift;
1.2       www       379: 
                    380:   if ($r->header_only) {
                    381:      $r->content_type('text/html');
                    382:      $r->send_http_header;
                    383:      return OK;
                    384:   }
                    385: 
                    386: # -------------------------------------------------------------- Check filename
                    387: 
                    388:   my $fn=$ENV{'form.filename'};
                    389: 
                    390:   unless ($fn) { 
                    391:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    392:          ' trying to publish empty filename', $r->filename); 
                    393:      return HTTP_NOT_FOUND;
                    394:   } 
1.4       www       395: 
                    396:   unless ($ENV{'user.home'} eq $r->dir_config('lonHostID')) {
                    397:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    398:          ' trying to publish file '.$ENV{'form.filename'}.
                    399:          ' ('.$fn.') - not homeserver ('.$ENV{'user.home'}.')', 
                    400:          $r->filename); 
                    401:      return HTTP_NOT_ACCEPTABLE;
                    402:   }
1.2       www       403: 
                    404:   $fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/;
                    405: 
                    406:   my $targetdir='';
                    407:   my $docroot=$r->dir_config('lonDocRoot'); 
                    408:   if ($1 ne $ENV{'user.name'}) {
                    409:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    410:          ' trying to publish unowned file '.$ENV{'form.filename'}.
                    411:          ' ('.$fn.')', 
                    412:          $r->filename); 
                    413:      return HTTP_NOT_ACCEPTABLE;
                    414:   } else {
                    415:       $targetdir=$docroot.'/res/'.$ENV{'user.domain'};
                    416:   }
                    417:                                  
                    418:   
                    419:   unless (-e $fn) { 
                    420:      $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}.
                    421:          ' trying to publish non-existing file '.$ENV{'form.filename'}.
                    422:          ' ('.$fn.')', 
                    423:          $r->filename); 
                    424:      return HTTP_NOT_FOUND;
                    425:   } 
                    426: 
                    427: # --------------------------------- File is there and owned, init lookup tables
                    428: 
1.3       www       429:   %addid=();
                    430: 
                    431:   {
                    432:       my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab');
                    433:       while (<$fh>=~/(\w+)\s+(\w+)/) {
                    434:           $addid{$1}=$2;
                    435:       }
1.5       www       436:   }
                    437: 
                    438:   %nokey=();
                    439: 
                    440:   {
                    441:      my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab');
                    442:       map {
                    443:           my $word=$_;
                    444:           chomp($word);
                    445:           $nokey{$word}=1;
1.9     ! www       446:       } <$fh>;
        !           447:   }
        !           448: 
        !           449:   %language=();
        !           450: 
        !           451:   {
        !           452:      my $fh=Apache::File->new($r->dir_config('lonTabDir').'/language.tab');
        !           453:       map {
        !           454:           $_=~/(\w+)\s+([\w\s]+)/;
        !           455:           $language{$1}=$2;
1.5       www       456:       } <$fh>;
1.3       www       457:   }
1.2       www       458: # ----------------------------------------------------------- Start page output
                    459: 
1.1       www       460:   $r->content_type('text/html');
                    461:   $r->send_http_header;
                    462: 
                    463:   $r->print('<html><head><title>LON-CAPA Publishing</title></head>');
                    464:   $r->print('<body bgcolor="#FFFFFF">');
1.2       www       465:   my $thisfn=$fn;
                    466:    
                    467: # ------------------------------------------------------------- Individual file
                    468:   {
                    469:       $thisfn=~/\.(\w+)$/;
                    470:       my $thistype=$1;
                    471:       my $thisembstyle=&Apache::lonnet::fileembstyle($thistype);
                    472: 
                    473:       my $thistarget=$thisfn;
                    474:       
                    475:       $thistarget=~s/^\/home/$targetdir/;
                    476:       $thistarget=~s/\/public\_html//;
                    477: 
                    478:       my $thisdistarget=$thistarget;
                    479:       $thisdistarget=~s/^$docroot//;
                    480: 
                    481:       my $thisdisfn=$thisfn;
                    482:       $thisdisfn=~s/^\/home\/$ENV{'user.name'}\/public_html\///;
                    483: 
                    484:       $r->print('<h2>Publishing '.
                    485:         &Apache::lonnet::filedescription($thistype).' <tt>'.
                    486:         $thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>');
                    487: 
                    488: # ------------ We are publishing from $thisfn to $thistarget with $thisembstyle
                    489: 
1.7       www       490:       $r->print('<hr>'.&publish($thisfn,$thistarget,$thisembstyle));
1.2       www       491:       
                    492:   }  
                    493: 
1.1       www       494:   $r->print('</body></html>');
                    495: 
                    496:   return OK;
                    497: }
                    498: 
                    499: 1;
                    500: __END__
                    501: 
                    502: 
                    503: 
                    504: 
                    505: 
                    506: 
                    507: 

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