loncom/publisher/lonpublisher.pm - view

File: [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.76: download - view: text, annotated - select for diffs
Wed Apr 10 15:28:45 2002 UTC (22 years, 1 month ago) by albertel
Branches: MAIN
CVS tags: HEAD

- address BUG#68 and BUG#153, also helps out with BUG#179
- metadata is now stored with Entities escaped, making it easy and possible to put HTML in metadata
- publication protects Entities beofre dumping them into the edit windos this should fix any issues with publishing Entities in metadata.
- attributes stay encoded during publication

1: # The LearningOnline Network with CAPA 2: # Publication Handler 3: # 4: # $Id: lonpublisher.pm,v 1.76 2002/04/10 15:28:45 albertel Exp $ 5: # 6: # Copyright Michigan State University Board of Trustees 7: # 8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 9: # 10: # LON-CAPA is free software; you can redistribute it and/or modify 11: # it under the terms of the GNU General Public License as published by 12: # the Free Software Foundation; either version 2 of the License, or 13: # (at your option) any later version. 14: # 15: # LON-CAPA is distributed in the hope that it will be useful, 16: # but WITHOUT ANY WARRANTY; without even the implied warranty of 17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18: # GNU General Public License for more details. 19: # 20: # You should have received a copy of the GNU General Public License 21: # along with LON-CAPA; if not, write to the Free Software 22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 23: # 24: # /home/httpd/html/adm/gpl.txt 25: # 26: # http://www.lon-capa.org/ 27: # 28: # 29: # (TeX Content Handler 30: # 31: # 05/29/00,05/30,10/11 Gerd Kortemeyer) 32: # 33: # 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer 34: # 03/23 Guy Albertelli 35: # 03/24,03/29,04/03 Gerd Kortemeyer 36: # 04/16/2001 Scott Harrison 37: # 05/03,05/05,05/07 Gerd Kortemeyer 38: # 05/28/2001 Scott Harrison 39: # 06/23,08/07,08/11,8/13,8/17,8/18,8/24,9/26,10/16 Gerd Kortemeyer 40: # 12/04,12/05 Guy Albertelli 41: # 12/05 Gerd Kortemeyer 42: # 12/05 Guy Albertelli 43: # 12/06,12/07 Gerd Kortemeyer 44: # 12/15,12/16 Scott Harrison 45: # 12/25 Gerd Kortemeyer 46: # YEAR=2002 47: # 1/16,1/17 Scott Harrison 48: # 1/17 Gerd Kortemeyer 49: # 50: ### 51: 52: ############################################################################### 53: ## ## 54: ## ORGANIZATION OF THIS PERL MODULE ## 55: ## ## 56: ## 1. Modules used by this module ## 57: ## 2. Various subroutines ## 58: ## 3. Publication Step One ## 59: ## 4. Phase Two ## 60: ## 5. Main Handler ## 61: ## ## 62: ############################################################################### 63: 64: package Apache::lonpublisher; 65: 66: # ------------------------------------------------- modules used by this module 67: use strict; 68: use Apache::File; 69: use File::Copy; 70: use Apache::Constants qw(:common :http :methods); 71: use HTML::LCParser; 72: use Apache::lonxml; 73: use Apache::lonhomework; 74: use Apache::loncacc; 75: use DBI; 76: use Apache::lonnet(); 77: use Apache::loncommon(); 78: 79: my %addid; 80: my %nokey; 81: 82: my %metadatafields; 83: my %metadatakeys; 84: 85: my $docroot; 86: 87: my $cuname; 88: my $cudom; 89: 90: # ----------------------------------------------- Evaluate string with metadata 91: sub metaeval { 92: my $metastring=shift; 93: 94: my $parser=HTML::LCParser->new(\$metastring); 95: my $token; 96: while ($token=$parser->get_token) { 97: if ($token->[0] eq 'S') { 98: my $entry=$token->[1]; 99: my $unikey=$entry; 100: if (defined($token->[2]->{'package'})) { 101: $unikey.='_package_'.$token->[2]->{'package'}; 102: } 103: if (defined($token->[2]->{'part'})) { 104: $unikey.='_'.$token->[2]->{'part'}; 105: } 106: if (defined($token->[2]->{'id'})) { 107: $unikey.='_'.$token->[2]->{'id'}; 108: } 109: if (defined($token->[2]->{'name'})) { 110: $unikey.='_'.$token->[2]->{'name'}; 111: } 112: foreach (@{$token->[3]}) { 113: $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; 114: if ($metadatakeys{$unikey}) { 115: $metadatakeys{$unikey}.=','.$_; 116: } else { 117: $metadatakeys{$unikey}=$_; 118: } 119: } 120: if ($metadatafields{$unikey}) { 121: my $newentry=$parser->get_text('/'.$entry); 122: unless (($metadatafields{$unikey}=~/$newentry/) || 123: ($newentry eq '')) { 124: $metadatafields{$unikey}.=', '.$newentry; 125: } 126: } else { 127: $metadatafields{$unikey}=$parser->get_text('/'.$entry); 128: } 129: } 130: } 131: } 132: 133: # -------------------------------------------------------- Read a metadata file 134: sub metaread { 135: my ($logfile,$fn)=@_; 136: unless (-e $fn) { 137: print $logfile 'No file '.$fn."\n"; 138: return '<br><b>No file:</b> <tt>'.$fn.'</tt>'; 139: } 140: print $logfile 'Processing '.$fn."\n"; 141: my $metastring; 142: { 143: my $metafh=Apache::File->new($fn); 144: $metastring=join('',<$metafh>); 145: } 146: &metaeval($metastring); 147: return '<br><b>Processed file:</b> <tt>'.$fn.'</tt>'; 148: } 149: 150: # ---------------------------- convert 'time' format into a datetime sql format 151: sub sqltime { 152: my $timef=shift @_; 153: my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 154: localtime($timef); 155: $mon++; $year+=1900; 156: return "$year-$mon-$mday $hour:$min:$sec"; 157: } 158: 159: # --------------------------------------------------------- Various form fields 160: 161: sub textfield { 162: my ($title,$name,$value)=@_; 163: return "\n<p><b>$title:</b><br>". 164: '<input type=text name="'.$name.'" size=80 value="'.$value.'">'; 165: } 166: 167: sub hiddenfield { 168: my ($name,$value)=@_; 169: return "\n".'<input type=hidden name="'.$name.'" value="'.$value.'">'; 170: } 171: 172: sub selectbox { 173: my ($title,$name,$value,$functionref,@idlist)=@_; 174: my $uctitle=uc($title); 175: my $selout="\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:". 176: "</b></font><br />".'<select name="'.$name.'">'; 177: foreach (@idlist) { 178: $selout.='<option value=\''.$_.'\''; 179: if ($_ eq $value) { 180: $selout.=' selected>'.&{$functionref}($_).'</option>'; 181: } 182: else {$selout.='>'.&{$functionref}($_).'</option>';} 183: } 184: return $selout.'</select>'; 185: } 186: 187: # -------------------------------------------------------- Publication Step One 188: 189: sub urlfixup { 190: my ($url,$target)=@_; 191: unless ($url) { return ''; } 192: #javascript code needs no fixing 193: if ($url =~ /^javascript:/i) { return $url; } 194: if ($url =~ /^mailto:/i) { return $url; } 195: #internal document links need no fixing 196: if ($url =~ /^\#/) { return $url; } 197: my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/); 198: foreach (values %Apache::lonnet::hostname) { 199: if ($_ eq $host) { 200: $url=~s/^http\:\/\///; 201: $url=~s/^$host//; 202: } 203: } 204: if ($url=~/^http\:\/\//) { return $url; } 205: $url=~s/\~$cuname/res\/$cudom\/$cuname/; 206: return $url; 207: } 208: 209: 210: sub absoluteurl { 211: my ($url,$target)=@_; 212: unless ($url) { return ''; } 213: if ($target) { 214: $target=~s/\/[^\/]+$//; 215: $url=&Apache::lonnet::hreflocation($target,$url); 216: } 217: return $url; 218: } 219: 220: sub publish { 221: 222: my ($source,$target,$style)=@_; 223: my $logfile; 224: my $scrout=''; 225: my $allmeta=''; 226: my $content=''; 227: my %allow=(); 228: undef %allow; 229: 230: unless ($logfile=Apache::File->new('>>'.$source.'.log')) { 231: return 232: '<font color=red>No write permission to user directory, FAIL</font>'; 233: } 234: print $logfile 235: "\n\n================= Publish ".localtime()." Phase One ================\n"; 236: 237: if (($style eq 'ssi') || ($style eq 'rat')) { 238: # ------------------------------------------------------- This needs processing 239: 240: # ----------------------------------------------------------------- Backup Copy 241: my $copyfile=$source.'.save'; 242: if (copy($source,$copyfile)) { 243: print $logfile "Copied original file to ".$copyfile."\n"; 244: } else { 245: print $logfile "Unable to write backup ".$copyfile.':'.$!."\n"; 246: return "<font color=red>Failed to write backup copy, $!,FAIL</font>"; 247: } 248: # ------------------------------------------------------------- IDs and indices 249: 250: my $maxindex=10; 251: my $maxid=10; 252: 253: my $needsfixup=0; 254: 255: { 256: my $org=Apache::File->new($source); 257: $content=join('',<$org>); 258: } 259: { 260: my $parser=HTML::LCParser->new(\$content); 261: my $token; 262: while ($token=$parser->get_token) { 263: if ($token->[0] eq 'S') { 264: my $counter; 265: if ($counter=$addid{$token->[1]}) { 266: if ($counter eq 'id') { 267: if (defined($token->[2]->{'id'})) { 268: $maxid= 269: ($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid; 270: } else { 271: $needsfixup=1; 272: } 273: } else { 274: if (defined($token->[2]->{'index'})) { 275: $maxindex= 276: ($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex; 277: } else { 278: $needsfixup=1; 279: } 280: } 281: } 282: } 283: } 284: } 285: if ($needsfixup) { 286: print $logfile "Needs ID and/or index fixup\n". 287: "Max ID : $maxid (min 10)\n". 288: "Max Index: $maxindex (min 10)\n"; 289: } 290: my $outstring=''; 291: my $parser=HTML::LCParser->new(\$content); 292: $parser->xml_mode(1); 293: my $token; 294: while ($token=$parser->get_token) { 295: if ($token->[0] eq 'S') { 296: my $counter; 297: my $tag=$token->[1]; 298: my $lctag=lc($tag); 299: unless ($lctag eq 'allow') { 300: my %parms=%{$token->[2]}; 301: $counter=$addid{$tag}; 302: if (!$counter) { $counter=$addid{$lctag}; } 303: if ($counter) { 304: if ($counter eq 'id') { 305: unless (defined($parms{'id'})) { 306: $maxid++; 307: $parms{'id'}=$maxid; 308: print $logfile 'ID: '.$tag.':'.$maxid."\n"; 309: } 310: } elsif ($counter eq 'index') { 311: unless (defined($parms{'index'})) { 312: $maxindex++; 313: $parms{'index'}=$maxindex; 314: print $logfile 'Index: '.$tag.':'.$maxindex."\n"; 315: } 316: } 317: } 318: 319: foreach my $type ('src','href','background','bgimg') { 320: foreach my $key (keys(%parms)) { 321: if ($key =~ /^$type$/i) { 322: my $oldurl=$parms{$key}; 323: my $newurl=&urlfixup($oldurl,$target); 324: if ($newurl ne $oldurl) { 325: $parms{$key}=$newurl; 326: print $logfile 'URL: '.$tag.':'.$oldurl.' - '. 327: $newurl."\n"; 328: } 329: if (($newurl !~ /^javascript:/i) && 330: ($newurl !~ /^mailto:/i) && 331: ($newurl !~ /^http:/i) && 332: ($newurl !~ /^\#/)) { 333: $allow{&absoluteurl($newurl,$target)}=1; 334: } 335: } 336: last; 337: } 338: } 339: 340: if ($lctag eq 'applet') { 341: my $codebase=''; 342: if (defined($parms{'codebase'})) { 343: my $oldcodebase=$parms{'codebase'}; 344: unless ($oldcodebase=~/\/$/) { 345: $oldcodebase.='/'; 346: } 347: $codebase=&urlfixup($oldcodebase,$target); 348: $codebase=~s/\/$//; 349: if ($codebase ne $oldcodebase) { 350: $parms{'codebase'}=$codebase; 351: print $logfile 'URL codebase: '.$tag.':'. 352: $oldcodebase.' - '. 353: $codebase."\n"; 354: } 355: $allow{&absoluteurl($codebase,$target).'/*'}=1; 356: } else { 357: foreach ('archive','code','object') { 358: if (defined($parms{$_})) { 359: my $oldurl=$parms{$_}; 360: my $newurl=&urlfixup($oldurl,$target); 361: $newurl=~s/\/[^\/]+$/\/\*/; 362: print $logfile 'Allow: applet '.$_.':'. 363: $oldurl.' allows '. 364: $newurl."\n"; 365: $allow{&absoluteurl($newurl,$target)}=1; 366: } 367: } 368: } 369: } 370: 371: my $newparmstring=''; 372: my $endtag=''; 373: foreach (keys %parms) { 374: if ($_ eq '/') { 375: $endtag=' /'; 376: } else { 377: my $quote=($parms{$_}=~/\"/?"'":'"'); 378: $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; 379: } 380: } 381: if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } 382: $outstring.='<'.$tag.$newparmstring.$endtag.'>'; 383: } else { 384: $allow{$token->[2]->{'src'}}=1; 385: } 386: } elsif ($token->[0] eq 'E') { 387: if ($token->[2]) { 388: unless ($token->[1] eq 'allow') { 389: $outstring.='</'.$token->[1].'>'; 390: } 391: } 392: } else { 393: $outstring.=$token->[1]; 394: } 395: } 396: # ------------------------------------------------------------ Construct Allows 397: 398: $scrout.='<h3>Dependencies</h3>'; 399: my $allowstr=''; 400: foreach (sort(keys(%allow))) { 401: my $thisdep=$_; 402: if ($thisdep !~ /[^\s]/) { next; } 403: unless ($style eq 'rat') { 404: $allowstr.="\n".'<allow src="'.$thisdep.'" />'; 405: } 406: $scrout.='<br>'; 407: unless ($thisdep=~/\*/) { 408: $scrout.='<a href="'.$thisdep.'">'; 409: } 410: $scrout.='<tt>'.$thisdep.'</tt>'; 411: unless ($thisdep=~/\*/) { 412: $scrout.='</a>'; 413: if ( 414: &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. 415: $thisdep.'.meta') eq '-1') { 416: $scrout.= 417: ' - <font color=red>Currently not available</font>'; 418: } else { 419: my %temphash=(&Apache::lonnet::declutter($target).'___'. 420: &Apache::lonnet::declutter($thisdep).'___usage' 421: => time); 422: $thisdep=~/^\/res\/(\w+)\/(\w+)\//; 423: if ((defined($1)) && (defined($2))) { 424: &Apache::lonnet::put('resevaldata',\%temphash,$1,$2); 425: } 426: } 427: } 428: } 429: $allowstr=~s/\n+/\n/g; 430: $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s; 431: 432: #Encode any High ASCII characters 433: $outstring=&HTML::Entities::encode($outstring,"\200-\377"); 434: # ------------------------------------------------------------- Write modified 435: 436: { 437: my $org; 438: unless ($org=Apache::File->new('>'.$source)) { 439: print $logfile "No write permit to $source\n"; 440: return 441: "<font color=red>No write permission to $source, FAIL</font>"; 442: } 443: print $org $outstring; 444: } 445: $content=$outstring; 446: 447: if ($needsfixup) { 448: print $logfile "End of ID and/or index fixup\n". 449: "Max ID : $maxid (min 10)\n". 450: "Max Index: $maxindex (min 10)\n"; 451: } else { 452: print $logfile "Does not need ID and/or index fixup\n"; 453: } 454: } 455: # --------------------------------------------- Initial step done, now metadata 456: 457: # ---------------------------------------- Storage for metadata keys and fields 458: 459: %metadatafields=(); 460: %metadatakeys=(); 461: 462: my %oldparmstores=(); 463: 464: $scrout.='<h3>Metadata Information</h3>'; 465: 466: # ------------------------------------------------ First, check out environment 467: unless (-e $source.'.meta') { 468: $metadatafields{'author'}=$ENV{'environment.firstname'}.' '. 469: $ENV{'environment.middlename'}.' '. 470: $ENV{'environment.lastname'}.' '. 471: $ENV{'environment.generation'}; 472: $metadatafields{'author'}=~s/\s+/ /g; 473: $metadatafields{'author'}=~s/\s+$//; 474: $metadatafields{'owner'}=$cuname.'@'.$cudom; 475: 476: # ------------------------------------------------ Check out directory hierachy 477: 478: my $thisdisfn=$source; 479: $thisdisfn=~s/^\/home\/$cuname\///; 480: 481: my @urlparts=split(/\//,$thisdisfn); 482: $#urlparts--; 483: 484: my $currentpath='/home/'.$cuname.'/'; 485: 486: foreach (@urlparts) { 487: $currentpath.=$_.'/'; 488: $scrout.=&metaread($logfile,$currentpath.'default.meta'); 489: } 490: 491: # ------------------- Clear out parameters and stores (there should not be any) 492: 493: foreach (keys %metadatafields) { 494: if (($_=~/^parameter/) || ($_=~/^stores/)) { 495: delete $metadatafields{$_}; 496: } 497: } 498: 499: } else { 500: # ---------------------- Read previous metafile, remember parameters and stores 501: 502: $scrout.=&metaread($logfile,$source.'.meta'); 503: 504: foreach (keys %metadatafields) { 505: if (($_=~/^parameter/) || ($_=~/^stores/)) { 506: $oldparmstores{$_}=1; 507: delete $metadatafields{$_}; 508: } 509: } 510: 511: } 512: 513: # -------------------------------------------------- Parse content for metadata 514: if ($style eq 'ssi') { 515: my $oldenv=$ENV{'request.uri'}; 516: 517: $ENV{'request.uri'}=$target; 518: $allmeta=Apache::lonxml::xmlparse('meta',$content); 519: $ENV{'request.uri'}=$oldenv; 520: 521: &metaeval($allmeta); 522: } 523: # ---------------- Find and document discrepancies in the parameters and stores 524: 525: my $chparms=''; 526: foreach (sort keys %metadatafields) { 527: if (($_=~/^parameter/) || ($_=~/^stores/)) { 528: unless ($_=~/\.\w+$/) { 529: unless ($oldparmstores{$_}) { 530: print $logfile 'New: '.$_."\n"; 531: $chparms.=$_.' '; 532: } 533: } 534: } 535: } 536: if ($chparms) { 537: $scrout.='<p><b>New parameters or stored values:</b> '. 538: $chparms; 539: } 540: 541: $chparms=''; 542: foreach (sort keys %oldparmstores) { 543: if (($_=~/^parameter/) || ($_=~/^stores/)) { 544: unless (($metadatafields{$_.'.name'}) || 545: ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { 546: print $logfile 'Obsolete: '.$_."\n"; 547: $chparms.=$_.' '; 548: } 549: } 550: } 551: if ($chparms) { 552: $scrout.='<p><b>Obsolete parameters or stored values:</b> '. 553: $chparms; 554: } 555: 556: # ------------------------------------------------------- Now have all metadata 557: 558: $scrout.= 559: '<form action="/adm/publish" method="post">'. 560: '<p><input type="submit" value="Finalize Publication" /></p>'. 561: &hiddenfield('phase','two'). 562: &hiddenfield('filename',$ENV{'form.filename'}). 563: &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)). 564: &hiddenfield('dependencies',join(',',keys %allow)). 565: &textfield('Title','title',$metadatafields{'title'}). 566: &textfield('Author(s)','author',$metadatafields{'author'}). 567: &textfield('Subject','subject',$metadatafields{'subject'}); 568: 569: # --------------------------------------------------- Scan content for keywords 570: 571: my $keywordout='<p><b>Keywords:</b><br><table border=2><tr>'; 572: my $colcount=0; 573: my %keywords=(); 574: 575: if (length($content)<500000) { 576: my $textonly=$content; 577: $textonly=~s/\<script[^\<]+\<\/script\>//g; 578: $textonly=~s/\<m\>[^\<]+\<\/m\>//g; 579: $textonly=~s/\<[^\>]*\>//g; 580: $textonly=~tr/A-Z/a-z/; 581: $textonly=~s/[\$\&][a-z]\w*//g; 582: $textonly=~s/[^a-z\s]//g; 583: 584: foreach ($textonly=~m/(\w+)/g) { 585: unless ($nokey{$_}) { 586: $keywords{$_}=1; 587: } 588: } 589: } 590: 591: 592: foreach (split(/\W+/,$metadatafields{'keywords'})) { 593: $keywords{$_}=1; 594: } 595: 596: foreach (sort keys %keywords) { 597: $keywordout.='<td><input type=checkbox name="key.'.$_.'"'; 598: if ($metadatafields{'keywords'}) { 599: if ($metadatafields{'keywords'}=~/$_/) { 600: $keywordout.=' checked'; 601: } 602: } elsif (&Apache::loncommon::keyword($_)) { 603: $keywordout.=' checked'; 604: } 605: $keywordout.='>'.$_.'</td>'; 606: if ($colcount>10) { 607: $keywordout.="</tr><tr>\n"; 608: $colcount=0; 609: } 610: $colcount++; 611: } 612: 613: $keywordout.='</tr></table>'; 614: 615: $scrout.=$keywordout; 616: 617: $scrout.=&textfield('Additional Keywords','addkey',''); 618: 619: $scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); 620: 621: $scrout.= 622: '<p><b>Abstract:</b><br><textarea cols=80 rows=5 name=abstract>'. 623: $metadatafields{'abstract'}.'</textarea>'; 624: 625: $source=~/\.(\w+)$/; 626: 627: $scrout.=&hiddenfield('mime',$1); 628: 629: $scrout.=&selectbox('Language','language', 630: $metadatafields{'language'}, 631: \&Apache::loncommon::languagedescription, 632: (&Apache::loncommon::languageids), 633: ); 634: 635: unless ($metadatafields{'creationdate'}) { 636: $metadatafields{'creationdate'}=time; 637: } 638: $scrout.=&hiddenfield('creationdate',$metadatafields{'creationdate'}); 639: 640: $scrout.=&hiddenfield('lastrevisiondate',time); 641: 642: 643: $scrout.=&textfield('Publisher/Owner','owner', 644: $metadatafields{'owner'}); 645: # --------------------------------------------------- Correct copyright for rat 646: if ($style eq 'rat') { 647: if ($metadatafields{'copyright'} eq 'public') { 648: delete $metadatafields{'copyright'}; 649: } 650: $scrout.=&selectbox('Copyright/Distribution','copyright', 651: $metadatafields{'copyright'}, 652: \&Apache::loncommon::copyrightdescription, 653: (grep !/^public$/,(&Apache::loncommon::copyrightids))); 654: } 655: else { 656: $scrout.=&selectbox('Copyright/Distribution','copyright', 657: $metadatafields{'copyright'}, 658: \&Apache::loncommon::copyrightdescription, 659: (&Apache::loncommon::copyrightids)); 660: } 661: return $scrout. 662: '<p><input type="submit" value="Finalize Publication" /></p></form>'; 663: } 664: 665: # -------------------------------------------------------- Publication Step Two 666: 667: sub phasetwo { 668: 669: my ($source,$target,$style,$distarget)=@_; 670: my $logfile; 671: my $scrout=''; 672: 673: unless ($logfile=Apache::File->new('>>'.$source.'.log')) { 674: return 675: '<font color=red>No write permission to user directory, FAIL</font>'; 676: } 677: print $logfile 678: "\n================= Publish ".localtime()." Phase Two ================\n"; 679: 680: %metadatafields=(); 681: %metadatakeys=(); 682: 683: &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'})); 684: 685: $metadatafields{'title'}=$ENV{'form.title'}; 686: $metadatafields{'author'}=$ENV{'form.author'}; 687: $metadatafields{'subject'}=$ENV{'form.subject'}; 688: $metadatafields{'notes'}=$ENV{'form.notes'}; 689: $metadatafields{'abstract'}=$ENV{'form.abstract'}; 690: $metadatafields{'mime'}=$ENV{'form.mime'}; 691: $metadatafields{'language'}=$ENV{'form.language'}; 692: $metadatafields{'creationdate'}=$ENV{'form.creationdate'}; 693: $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'}; 694: $metadatafields{'owner'}=$ENV{'form.owner'}; 695: $metadatafields{'copyright'}=$ENV{'form.copyright'}; 696: $metadatafields{'dependencies'}=$ENV{'form.dependencies'}; 697: 698: my $allkeywords=$ENV{'form.addkey'}; 699: foreach (keys %ENV) { 700: if ($_=~/^form\.key\.(\w+)/) { 701: $allkeywords.=','.$1; 702: } 703: } 704: $allkeywords=~s/\W+/\,/; 705: $allkeywords=~s/^\,//; 706: $metadatafields{'keywords'}=$allkeywords; 707: 708: { 709: print $logfile "\nWrite metadata file for ".$source; 710: my $mfh; 711: unless ($mfh=Apache::File->new('>'.$source.'.meta')) { 712: return 713: '<font color=red>Could not write metadata, FAIL</font>'; 714: } 715: foreach (sort keys %metadatafields) { 716: unless ($_=~/\./) { 717: my $unikey=$_; 718: $unikey=~/^([A-Za-z]+)/; 719: my $tag=$1; 720: $tag=~tr/A-Z/a-z/; 721: print $mfh "\n\<$tag"; 722: foreach (split(/\,/,$metadatakeys{$unikey})) { 723: my $value=$metadatafields{$unikey.'.'.$_}; 724: $value=~s/\"/\'\'/g; 725: print $mfh ' '.$_.'="'.$value.'"'; 726: } 727: print $mfh '>'. 728: &HTML::Entities::encode($metadatafields{$unikey}) 729: .'</'.$tag.'>'; 730: } 731: } 732: $scrout.='<p>Wrote Metadata'; 733: print $logfile "\nWrote metadata"; 734: } 735: 736: # -------------------------------- Synchronize entry with SQL metadata database 737: my $warning; 738: 739: unless ($metadatafields{'copyright'} eq 'priv') { 740: 741: my $dbh; 742: { 743: unless ( 744: $dbh = DBI->connect("DBI:mysql:loncapa","www", 745: $Apache::lonnet::perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) 746: ) { 747: $warning='<font color=red>WARNING: Cannot connect to '. 748: 'database!</font>'; 749: } 750: else { 751: my %sqldatafields; 752: $sqldatafields{'url'}=$distarget; 753: my $sth=$dbh->prepare( 754: 'delete from metadata where url like binary'. 755: '"'.$sqldatafields{'url'}.'"'); 756: $sth->execute(); 757: foreach ('title','author','subject','keywords','notes','abstract', 758: 'mime','language','creationdate','lastrevisiondate','owner', 759: 'copyright') { 760: my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g; 761: $sqldatafields{$_}=$field; 762: } 763: 764: $sth=$dbh->prepare('insert into metadata values ('. 765: '"'.delete($sqldatafields{'title'}).'"'.','. 766: '"'.delete($sqldatafields{'author'}).'"'.','. 767: '"'.delete($sqldatafields{'subject'}).'"'.','. 768: '"'.delete($sqldatafields{'url'}).'"'.','. 769: '"'.delete($sqldatafields{'keywords'}).'"'.','. 770: '"'.'current'.'"'.','. 771: '"'.delete($sqldatafields{'notes'}).'"'.','. 772: '"'.delete($sqldatafields{'abstract'}).'"'.','. 773: '"'.delete($sqldatafields{'mime'}).'"'.','. 774: '"'.delete($sqldatafields{'language'}).'"'.','. 775: '"'. 776: sqltime(delete($sqldatafields{'creationdate'})) 777: .'"'.','. 778: '"'. 779: sqltime(delete( 780: $sqldatafields{'lastrevisiondate'})).'"'.','. 781: '"'.delete($sqldatafields{'owner'}).'"'.','. 782: '"'.delete( 783: $sqldatafields{'copyright'}).'"'.')'); 784: $sth->execute(); 785: $dbh->disconnect; 786: $scrout.='<p>Synchronized SQL metadata database'; 787: print $logfile "\nSynchronized SQL metadata database"; 788: } 789: } 790: 791: } else { 792: $scrout.='<p>Private Publication - did not synchronize database'; 793: print $logfile "\nPrivate: Did not synchronize data into ". 794: "SQL metadata database"; 795: } 796: # ----------------------------------------------------------- Copy old versions 797: 798: if (-e $target) { 799: my $filename; 800: my $maxversion=0; 801: $target=~/(.*)\/([^\/]+)\.(\w+)$/; 802: my $srcf=$2; 803: my $srct=$3; 804: my $srcd=$1; 805: unless ($srcd=~/^\/home\/httpd\/html\/res/) { 806: print $logfile "\nPANIC: Target dir is ".$srcd; 807: return "<font color=red>Invalid target directory, FAIL</font>"; 808: } 809: opendir(DIR,$srcd); 810: while ($filename=readdir(DIR)) { 811: if ($filename=~/$srcf\.(\d+)\.$srct$/) { 812: $maxversion=($1>$maxversion)?$1:$maxversion; 813: } 814: } 815: closedir(DIR); 816: $maxversion++; 817: $scrout.='<p>Creating old version '.$maxversion; 818: print $logfile "\nCreating old version ".$maxversion; 819: 820: my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct; 821: 822: if (copy($target,$copyfile)) { 823: print $logfile "Copied old target to ".$copyfile."\n"; 824: $scrout.='<p>Copied old target file'; 825: } else { 826: print $logfile "Unable to write ".$copyfile.':'.$!."\n"; 827: return "<font color=red>Failed to copy old target, $!, FAIL</font>"; 828: } 829: 830: # --------------------------------------------------------------- Copy Metadata 831: 832: $copyfile=$copyfile.'.meta'; 833: 834: if (copy($target.'.meta',$copyfile)) { 835: print $logfile "Copied old target metadata to ".$copyfile."\n"; 836: $scrout.='<p>Copied old metadata'; 837: } else { 838: print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; 839: if (-e $target.'.meta') { 840: return 841: "<font color=red>Failed to write old metadata copy, $!, FAIL</font>"; 842: } 843: } 844: 845: 846: } else { 847: $scrout.='<p>Initial version'; 848: print $logfile "\nInitial version"; 849: } 850: 851: # ---------------------------------------------------------------- Write Source 852: my $copyfile=$target; 853: 854: my @parts=split(/\//,$copyfile); 855: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 856: 857: my $count; 858: for ($count=5;$count<$#parts;$count++) { 859: $path.="/$parts[$count]"; 860: if ((-e $path)!=1) { 861: print $logfile "\nCreating directory ".$path; 862: $scrout.='<p>Created directory '.$parts[$count]; 863: mkdir($path,0777); 864: } 865: } 866: 867: if (copy($source,$copyfile)) { 868: print $logfile "Copied original source to ".$copyfile."\n"; 869: $scrout.='<p>Copied source file'; 870: } else { 871: print $logfile "Unable to write ".$copyfile.':'.$!."\n"; 872: return "<font color=red>Failed to copy source, $!, FAIL</font>"; 873: } 874: 875: # --------------------------------------------------------------- Copy Metadata 876: 877: $copyfile=$copyfile.'.meta'; 878: 879: if (copy($source.'.meta',$copyfile)) { 880: print $logfile "Copied original metadata to ".$copyfile."\n"; 881: $scrout.='<p>Copied metadata'; 882: } else { 883: print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; 884: return 885: "<font color=red>Failed to write metadata copy, $!, FAIL</font>"; 886: } 887: 888: # --------------------------------------------------- Send update notifications 889: 890: { 891: 892: my $filename; 893: 894: $target=~/(.*)\/([^\/]+)$/; 895: my $srcf=$2; 896: opendir(DIR,$1); 897: while ($filename=readdir(DIR)) { 898: if ($filename=~/$srcf\.(\w+)$/) { 899: my $subhost=$1; 900: if ($subhost ne 'meta') { 901: $scrout.='<p>Notifying host '.$subhost.':'; 902: print $logfile "\nNotifying host '.$subhost.':'"; 903: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); 904: $scrout.=$reply; 905: print $logfile $reply; 906: } 907: } 908: } 909: closedir(DIR); 910: 911: } 912: 913: # ---------------------------------------- Send update notifications, meta only 914: 915: { 916: 917: my $filename; 918: 919: $target=~/(.*)\/([^\/]+)$/; 920: my $srcf=$2.'.meta'; 921: opendir(DIR,$1); 922: while ($filename=readdir(DIR)) { 923: if ($filename=~/$srcf\.(\w+)$/) { 924: my $subhost=$1; 925: if ($subhost ne 'meta') { 926: $scrout.= 927: '<p>Notifying host for metadata only '.$subhost.':'; 928: print $logfile 929: "\nNotifying host for metadata only '.$subhost.':'"; 930: my $reply=&Apache::lonnet::critical( 931: 'update:'.$target.'.meta',$subhost); 932: $scrout.=$reply; 933: print $logfile $reply; 934: } 935: } 936: } 937: closedir(DIR); 938: 939: } 940: 941: # ------------------------------------------------ Provide link to new resource 942: 943: my $thisdistarget=$target; 944: $thisdistarget=~s/^$docroot//; 945: 946: my $thissrc=$source; 947: $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/; 948: 949: my $thissrcdir=$thissrc; 950: $thissrcdir=~s/\/[^\/]+$/\//; 951: 952: 953: return $warning.$scrout. 954: '<hr><a href="'.$thisdistarget.'"><font size=+2>View Published Version</font></a>'. 955: '<p><a href="'.$thissrc.'"><font size=+2>Back to Source</font></a>'. 956: '<p><a href="'.$thissrcdir. 957: '"><font size=+2>Back to Source Directory</font></a>'; 958: 959: } 960: 961: # ================================================================ Main Handler 962: 963: sub handler { 964: my $r=shift; 965: 966: if ($r->header_only) { 967: $r->content_type('text/html'); 968: $r->send_http_header; 969: return OK; 970: } 971: 972: # Get query string for limited number of parameters 973: 974: foreach (split(/&/,$ENV{'QUERY_STRING'})) { 975: my ($name, $value) = split(/=/,$_); 976: $value =~ tr/+/ /; 977: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 978: if ($name eq 'filename') { 979: unless ($ENV{'form.'.$name}) { 980: $ENV{'form.'.$name}=$value; 981: } 982: } 983: } 984: 985: 986: # -------------------------------------------------------------- Check filename 987: 988: my $fn=$ENV{'form.filename'}; 989: 990: 991: unless ($fn) { 992: $r->log_reason($cuname.' at '.$cudom. 993: ' trying to publish empty filename', $r->filename); 994: return HTTP_NOT_FOUND; 995: } 996: 997: ($cuname,$cudom)= 998: &Apache::loncacc::constructaccess($fn,$r->dir_config('lonDefDomain')); 999: unless (($cuname) && ($cudom)) { 1000: $r->log_reason($cuname.' at '.$cudom. 1001: ' trying to publish file '.$ENV{'form.filename'}. 1002: ' ('.$fn.') - not authorized', 1003: $r->filename); 1004: return HTTP_NOT_ACCEPTABLE; 1005: } 1006: 1007: unless (&Apache::lonnet::homeserver($cuname,$cudom) 1008: eq $r->dir_config('lonHostID')) { 1009: $r->log_reason($cuname.' at '.$cudom. 1010: ' trying to publish file '.$ENV{'form.filename'}. 1011: ' ('.$fn.') - not homeserver ('. 1012: &Apache::lonnet::homeserver($cuname,$cudom).')', 1013: $r->filename); 1014: return HTTP_NOT_ACCEPTABLE; 1015: } 1016: 1017: $fn=~s/^http\:\/\/[^\/]+//; 1018: $fn=~s/^\/\~(\w+)/\/home\/$1\/public_html/; 1019: 1020: my $targetdir=''; 1021: $docroot=$r->dir_config('lonDocRoot'); 1022: if ($1 ne $cuname) { 1023: $r->log_reason($cuname.' at '.$cudom. 1024: ' trying to publish unowned file '.$ENV{'form.filename'}. 1025: ' ('.$fn.')', 1026: $r->filename); 1027: return HTTP_NOT_ACCEPTABLE; 1028: } else { 1029: $targetdir=$docroot.'/res/'.$cudom; 1030: } 1031: 1032: 1033: unless (-e $fn) { 1034: $r->log_reason($cuname.' at '.$cudom. 1035: ' trying to publish non-existing file '.$ENV{'form.filename'}. 1036: ' ('.$fn.')', 1037: $r->filename); 1038: return HTTP_NOT_FOUND; 1039: } 1040: 1041: unless ($ENV{'form.phase'} eq 'two') { 1042: 1043: # --------------------------------- File is there and owned, init lookup tables 1044: 1045: %addid=(); 1046: 1047: { 1048: my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab'); 1049: while (<$fh>=~/(\w+)\s+(\w+)/) { 1050: $addid{$1}=$2; 1051: } 1052: } 1053: 1054: %nokey=(); 1055: 1056: { 1057: my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); 1058: while (<$fh>) { 1059: my $word=$_; 1060: chomp($word); 1061: $nokey{$word}=1; 1062: } 1063: } 1064: 1065: } 1066: 1067: # ----------------------------------------------------------- Start page output 1068: 1069: $r->content_type('text/html'); 1070: $r->send_http_header; 1071: 1072: $r->print('<html><head><title>LON-CAPA Publishing</title></head>'); 1073: $r->print( 1074: '<body bgcolor="#FFFFFF"><img align=right src=/adm/lonIcons/lonlogos.gif>'); 1075: my $thisfn=$fn; 1076: 1077: # ------------------------------------------------------------- Individual file 1078: { 1079: $thisfn=~/\.(\w+)$/; 1080: my $thistype=$1; 1081: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); 1082: 1083: my $thistarget=$thisfn; 1084: 1085: $thistarget=~s/^\/home/$targetdir/; 1086: $thistarget=~s/\/public\_html//; 1087: 1088: my $thisdistarget=$thistarget; 1089: $thisdistarget=~s/^$docroot//; 1090: 1091: my $thisdisfn=$thisfn; 1092: $thisdisfn=~s/^\/home\/$cuname\/public_html\///; 1093: 1094: $r->print('<h2>Publishing '. 1095: &Apache::loncommon::filedescription($thistype).' <tt>'. 1096: $thisdisfn.'</tt></h2><b>Target:</b> <tt>'.$thisdistarget.'</tt><p>'); 1097: 1098: if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) { 1099: $r->print('<h3><font color=red>Co-Author: '.$cuname.' at '.$cudom. 1100: '</font></h3>'); 1101: } 1102: 1103: if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { 1104: $r->print('<br><a href="/adm/diff?filename=/~'.$cuname.'/'. 1105: $thisdisfn. 1106: '&versionone=priv" target=cat>Diffs with Current Version</a><p>'); 1107: } 1108: 1109: # ------------ We are publishing from $thisfn to $thistarget with $thisembstyle 1110: 1111: unless ($ENV{'form.phase'} eq 'two') { 1112: $r->print( 1113: '<hr>'.&publish($thisfn,$thistarget,$thisembstyle)); 1114: } else { 1115: $r->print( 1116: '<hr>'.&phasetwo($thisfn,$thistarget,$thisembstyle,$thisdistarget)); 1117: } 1118: 1119: } 1120: $r->print('</body></html>'); 1121: 1122: return OK; 1123: } 1124: 1125: 1; 1126: __END__ 1127: 1128: =head1 NAME 1129: 1130: Apache::lonpublisher - Publication Handler 1131: 1132: =head1 SYNOPSIS 1133: 1134: Invoked by /etc/httpd/conf/srm.conf: 1135: 1136: <Location /adm/publish> 1137: PerlAccessHandler Apache::lonacc 1138: SetHandler perl-script 1139: PerlHandler Apache::lonpublisher 1140: ErrorDocument 403 /adm/login 1141: ErrorDocument 404 /adm/notfound.html 1142: ErrorDocument 406 /adm/unauthorized.html 1143: ErrorDocument 500 /adm/errorhandler 1144: </Location> 1145: 1146: =head1 INTRODUCTION 1147: 1148: This module publishes a file. This involves gathering metadata, 1149: versioning the file, copying file from construction space to 1150: publication space, and copying metadata from construction space 1151: to publication space. 1152: 1153: This is part of the LearningOnline Network with CAPA project 1154: described at http://www.lon-capa.org. 1155: 1156: =head1 HANDLER SUBROUTINE 1157: 1158: This routine is called by Apache and mod_perl. 1159: 1160: =over 4 1161: 1162: =item * 1163: 1164: Get query string for limited number of parameters 1165: 1166: =item * 1167: 1168: Check filename 1169: 1170: =item * 1171: 1172: File is there and owned, init lookup tables 1173: 1174: =item * 1175: 1176: Start page output 1177: 1178: =item * 1179: 1180: Individual file 1181: 1182: =item * 1183: 1184: publish from $thisfn to $thistarget with $thisembstyle 1185: 1186: =back 1187: 1188: =head1 OTHER SUBROUTINES 1189: 1190: =over 4 1191: 1192: =item * 1193: 1194: metaeval() : Evaluate string with metadata 1195: 1196: =item * 1197: 1198: metaread() : Read a metadata file 1199: 1200: =item * 1201: 1202: sqltime() : convert 'time' format into a datetime sql format 1203: 1204: =item * 1205: 1206: textfield() : form field 1207: 1208: =item * 1209: 1210: hiddenfield() : form field 1211: 1212: =item * 1213: 1214: selectbox() : form field 1215: 1216: =item * 1217: 1218: urlfixup() : fixup URL (Publication Step One) 1219: 1220: =item * 1221: 1222: publish() : publish (Publication Step One) 1223: 1224: =item * 1225: 1226: phasetwo() : render second interface showing status of publication steps 1227: (Publication Step Two) 1228: 1229: =back 1230: 1231: =cut