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

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

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