loncom/publisher/lonpublisher.pm - view

File: [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.163: download - view: text, annotated - select for diffs
Tue Jan 27 22:54:59 2004 UTC (20 years, 3 months ago) by albertel
Branches: MAIN
CVS tags: HEAD

- supporting authors on multidomain machines
  - this works, but requires that all users that author have unique usernames
    ( I.e. albertel@basement and albertel@annarbor will end up accessing the same /home/albertel/public_html)
- I plan on isntalling this on s17.lite.msu.edu to support the serway@brookscole user

1: # The LearningOnline Network with CAPA 2: # Publication Handler 3: # 4: # $Id: lonpublisher.pm,v 1.163 2004/01/27 22:54:59 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: 30: ############################################################################### 31: ## ## 32: ## ORGANIZATION OF THIS PERL MODULE ## 33: ## ## 34: ## 1. Modules used by this module ## 35: ## 2. Various subroutines ## 36: ## 3. Publication Step One ## 37: ## 4. Phase Two ## 38: ## 5. Main Handler ## 39: ## ## 40: ############################################################################### 41: 42: 43: ###################################################################### 44: ###################################################################### 45: 46: =pod 47: 48: =head1 NAME 49: 50: lonpublisher - LON-CAPA publishing handler 51: 52: =head1 SYNOPSIS 53: 54: B<lonpublisher> is used by B<mod_perl> inside B<Apache>. This is the 55: invocation by F<loncapa_apache.conf>: 56: 57: <Location /adm/publish> 58: PerlAccessHandler Apache::lonacc 59: SetHandler perl-script 60: PerlHandler Apache::lonpublisher 61: ErrorDocument 403 /adm/login 62: ErrorDocument 404 /adm/notfound.html 63: ErrorDocument 406 /adm/unauthorized.html 64: ErrorDocument 500 /adm/errorhandler 65: </Location> 66: 67: =head1 OVERVIEW 68: 69: Authors can only write-access the C</~authorname/> space. They can 70: copy resources into the resource area through the publication step, 71: and move them back through a recover step. Authors do not have direct 72: write-access to their resource space. 73: 74: During the publication step, several events will be 75: triggered. Metadata is gathered, where a wizard manages default 76: entries on a hierarchical per-directory base: The wizard imports the 77: metadata (including access privileges and royalty information) from 78: the most recent published resource in the current directory, and if 79: that is not available, from the next directory above, etc. The Network 80: keeps all previous versions of a resource and makes them available by 81: an explicit version number, which is inserted between the file name 82: and extension, for example C<foo.2.html>, while the most recent 83: version does not carry a version number (C<foo.html>). Servers 84: subscribing to a changed resource are notified that a new version is 85: available. 86: 87: =head1 DESCRIPTION 88: 89: B<lonpublisher> takes the proper steps to add resources to the LON-CAPA 90: digital library. This includes updating the metadata table in the 91: LON-CAPA database. 92: 93: B<lonpublisher> is many things to many people. 94: 95: This module publishes a file. This involves gathering metadata, 96: versioning the file, copying file from construction space to 97: publication space, and copying metadata from construction space 98: to publication space. 99: 100: =head2 SUBROUTINES 101: 102: Many of the undocumented subroutines implement various magical 103: parsing shortcuts. 104: 105: =over 4 106: 107: =cut 108: 109: ###################################################################### 110: ###################################################################### 111: 112: 113: package Apache::lonpublisher; 114: 115: # ------------------------------------------------- modules used by this module 116: use strict; 117: use Apache::File; 118: use File::Copy; 119: use Apache::Constants qw(:common :http :methods); 120: use HTML::LCParser; 121: use Apache::lonxml; 122: use Apache::loncacc; 123: use DBI; 124: use Apache::lonnet(); 125: use Apache::loncommon(); 126: use Apache::lonmysql; 127: use Apache::lonlocal; 128: use Apache::loncfile; 129: use Apache::lonmeta; 130: use Apache::lonmsg; 131: use vars qw(%metadatafields %metadatakeys); 132: 133: my %addid; 134: my %nokey; 135: 136: my $docroot; 137: 138: my $cuname; 139: my $cudom; 140: 141: =pod 142: 143: =item B<metaeval> 144: 145: Evaluates a string that contains metadata. This subroutine 146: stores values inside I<%metadatafields> and I<%metadatakeys>. 147: The hash key is a I<$unikey> corresponding to a unique id 148: that is descriptive of the parser location inside the XML tree. 149: 150: Parameters: 151: 152: =over 4 153: 154: =item I<$metastring> 155: 156: A string that contains metadata. 157: 158: =back 159: 160: Returns: 161: 162: nothing 163: 164: =cut 165: 166: ######################################### 167: ######################################### 168: # 169: # Modifies global %metadatafields %metadatakeys 170: # 171: 172: sub metaeval { 173: my ($metastring,$prefix)=@_; 174: 175: my $parser=HTML::LCParser->new(\$metastring); 176: my $token; 177: while ($token=$parser->get_token) { 178: if ($token->[0] eq 'S') { 179: my $entry=$token->[1]; 180: my $unikey=$entry; 181: if (defined($token->[2]->{'package'})) { 182: $unikey.='_package_'.$token->[2]->{'package'}; 183: } 184: if (defined($token->[2]->{'part'})) { 185: $unikey.='_'.$token->[2]->{'part'}; 186: } 187: if (defined($token->[2]->{'id'})) { 188: $unikey.='_'.$token->[2]->{'id'}; 189: } 190: if (defined($token->[2]->{'name'})) { 191: $unikey.='_'.$token->[2]->{'name'}; 192: } 193: foreach (@{$token->[3]}) { 194: $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; 195: if ($metadatakeys{$unikey}) { 196: $metadatakeys{$unikey}.=','.$_; 197: } else { 198: $metadatakeys{$unikey}=$_; 199: } 200: } 201: my $newentry=$parser->get_text('/'.$entry); 202: if ($entry eq 'customdistributionfile') { 203: $newentry=~s/^\s*//; 204: if ($newentry !~m|^/res|) { $newentry=$prefix.$newentry; } 205: } 206: # actually store 207: if ( $entry eq 'rule' && exists($metadatafields{$unikey})) { 208: $metadatafields{$unikey}.=','.$newentry; 209: } else { 210: $metadatafields{$unikey}=$newentry; 211: } 212: } 213: } 214: } 215: 216: ######################################### 217: ######################################### 218: 219: =pod 220: 221: =item B<metaread> 222: 223: Read a metadata file 224: 225: Parameters: 226: 227: =over 228: 229: =item I<$logfile> 230: 231: File output stream to output errors and warnings to. 232: 233: =item I<$fn> 234: 235: File name (including path). 236: 237: =back 238: 239: Returns: 240: 241: =over 4 242: 243: =item Scalar string (if successful) 244: 245: XHTML text that indicates successful reading of the metadata. 246: 247: =back 248: 249: =cut 250: 251: ######################################### 252: ######################################### 253: sub metaread { 254: my ($logfile,$fn,$prefix)=@_; 255: unless (-e $fn) { 256: print($logfile 'No file '.$fn."\n"); 257: return ' '.&mt('No file').': <tt>'. 258: &Apache::loncfile::display($fn).'</tt>'; 259: } 260: print($logfile 'Processing '.$fn."\n"); 261: my $metastring; 262: { 263: my $metafh=Apache::File->new($fn); 264: $metastring=join('',<$metafh>); 265: } 266: &metaeval($metastring,$prefix); 267: return ' '.&mt('Processed file').': <tt>'. 268: &Apache::loncfile::display($fn).'</tt>'; 269: } 270: 271: ######################################### 272: ######################################### 273: 274: sub coursedependencies { 275: my $url=&Apache::lonnet::declutter(shift); 276: $url=~s/\.meta$//; 277: my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//); 278: my $regexp=$url; 279: $regexp=~s/(\W)/\\$1/g; 280: $regexp='___'.$regexp.'___course'; 281: my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain, 282: $aauthor,$regexp); 283: my %courses=(); 284: foreach (keys %evaldata) { 285: if ($_=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) { 286: $courses{$1}=1; 287: } 288: } 289: return %courses; 290: } 291: ######################################### 292: ######################################### 293: 294: 295: =pod 296: 297: =item Form-field-generating subroutines. 298: 299: For input parameters, these subroutines take in values 300: such as I<$name>, I<$value> and other form field metadata. 301: The output (scalar string that is returned) is an XHTML 302: string which presents the form field (foreseeably inside 303: <form></form> tags). 304: 305: =over 4 306: 307: =item B<textfield> 308: 309: =item B<hiddenfield> 310: 311: =item B<selectbox> 312: 313: =back 314: 315: =cut 316: 317: ######################################### 318: ######################################### 319: sub textfield { 320: my ($title,$name,$value)=@_; 321: $value=~s/^\s+//gs; 322: $value=~s/\s+$//gs; 323: $value=~s/\s+/ /gs; 324: $title=&mt($title); 325: return "\n$title:". 326: " ". 327: '<input type="text" name="'.$name.'" size=80 value="'.$value.'" />'; 328: } 329: 330: sub hiddenfield { 331: my ($name,$value)=@_; 332: return "\n".'<input type="hidden" name="'.$name.'" value="'.$value.'" />'; 333: } 334: 335: sub selectbox { 336: my ($title,$name,$value,$functionref,@idlist)=@_; 337: $title=&mt($title); 338: $value=(split(/\s*,\s*/,$value))[-1]; 339: my $selout="\n$title:". 340: ' <select name="'.$name.'">'; 341: foreach (@idlist) { 342: $selout.='<option value=\''.$_.'\''; 343: if ($_ eq $value) { 344: $selout.=' selected>'.&{$functionref}($_).'</option>'; 345: } 346: else {$selout.='>'.&{$functionref}($_).'</option>';} 347: } 348: return $selout.'</select>'; 349: } 350: 351: ######################################### 352: ######################################### 353: 354: =pod 355: 356: =item B<urlfixup> 357: 358: Fix up a url? First step of publication 359: 360: =cut 361: 362: ######################################### 363: ######################################### 364: sub urlfixup { 365: my ($url,$target)=@_; 366: unless ($url) { return ''; } 367: #javascript code needs no fixing 368: if ($url =~ /^javascript:/i) { return $url; } 369: if ($url =~ /^mailto:/i) { return $url; } 370: #internal document links need no fixing 371: if ($url =~ /^\#/) { return $url; } 372: my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/); 373: foreach (values %Apache::lonnet::hostname) { 374: if ($_ eq $host) { 375: $url=~s/^http\:\/\///; 376: $url=~s/^$host//; 377: } 378: } 379: if ($url=~/^http\:\/\//) { return $url; } 380: $url=~s/\~$cuname/res\/$cudom\/$cuname/; 381: return $url; 382: } 383: 384: ######################################### 385: ######################################### 386: 387: =pod 388: 389: =item B<absoluteurl> 390: 391: Currently undocumented. 392: 393: =cut 394: 395: ######################################### 396: ######################################### 397: sub absoluteurl { 398: my ($url,$target)=@_; 399: unless ($url) { return ''; } 400: if ($target) { 401: $target=~s/\/[^\/]+$//; 402: $url=&Apache::lonnet::hreflocation($target,$url); 403: } 404: return $url; 405: } 406: 407: ######################################### 408: ######################################### 409: 410: =pod 411: 412: =item B<set_allow> 413: 414: Currently undocumented 415: 416: =cut 417: 418: ######################################### 419: ######################################### 420: sub set_allow { 421: my ($allow,$logfile,$target,$tag,$oldurl)=@_; 422: my $newurl=&urlfixup($oldurl,$target); 423: my $return_url=$oldurl; 424: print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; 425: if ($newurl ne $oldurl) { 426: $return_url=$newurl; 427: print $logfile 'URL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; 428: } 429: if (($newurl !~ /^javascript:/i) && 430: ($newurl !~ /^mailto:/i) && 431: ($newurl !~ /^http:/i) && 432: ($newurl !~ /^\#/)) { 433: $$allow{&absoluteurl($newurl,$target)}=1; 434: } 435: return $return_url 436: } 437: 438: ######################################### 439: ######################################### 440: 441: =pod 442: 443: =item B<get_subscribed_hosts> 444: 445: Currently undocumented 446: 447: =cut 448: 449: ######################################### 450: ######################################### 451: sub get_subscribed_hosts { 452: my ($target)=@_; 453: my @subscribed; 454: my $filename; 455: $target=~/(.*)\/([^\/]+)$/; 456: my $srcf=$2; 457: opendir(DIR,$1); 458: while ($filename=readdir(DIR)) { 459: if ($filename=~/\Q$srcf\E\.(\w+)$/) { 460: my $subhost=$1; 461: if (($subhost ne 'meta' && $subhost ne 'subscription') && 462: ($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) { 463: push(@subscribed,$subhost); 464: } 465: } 466: } 467: closedir(DIR); 468: my $sh; 469: if ( $sh=Apache::File->new("$target.subscription") ) { 470: &Apache::lonnet::logthis("opened $target.subscription"); 471: while (my $subline=<$sh>) { 472: &Apache::lonnet::logthis("Trying $subline"); 473: if ($subline =~ /(^\w+):/) { 474: if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) { 475: push(@subscribed,$1); 476: } 477: } else { 478: &Apache::lonnet::logthis("No Match for $subline"); 479: } 480: } 481: } else { 482: &Apache::lonnet::logthis("Unable to open $target.subscription"); 483: } 484: return @subscribed; 485: } 486: 487: 488: ######################################### 489: ######################################### 490: 491: =pod 492: 493: =item B<get_max_ids_indices> 494: 495: Currently undocumented 496: 497: =cut 498: 499: ######################################### 500: ######################################### 501: sub get_max_ids_indices { 502: my ($content)=@_; 503: my $maxindex=10; 504: my $maxid=10; 505: my $needsfixup=0; 506: my $duplicateids=0; 507: 508: my %allids; 509: my %duplicatedids; 510: 511: my $parser=HTML::LCParser->new($content); 512: my $token; 513: while ($token=$parser->get_token) { 514: if ($token->[0] eq 'S') { 515: my $counter; 516: if ($counter=$addid{$token->[1]}) { 517: if ($counter eq 'id') { 518: if (defined($token->[2]->{'id'})) { 519: $maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid; 520: if (exists($allids{$token->[2]->{'id'}})) { 521: $duplicateids=1; 522: $duplicatedids{$token->[2]->{'id'}}=1; 523: } else { 524: $allids{$token->[2]->{'id'}}=1; 525: } 526: } else { 527: $needsfixup=1; 528: } 529: } else { 530: if (defined($token->[2]->{'index'})) { 531: $maxindex=($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex; 532: } else { 533: $needsfixup=1; 534: } 535: } 536: } 537: } 538: } 539: return ($needsfixup,$maxid,$maxindex,$duplicateids, 540: (keys(%duplicatedids))); 541: } 542: 543: ######################################### 544: ######################################### 545: 546: =pod 547: 548: =item B<get_all_text_unbalanced> 549: 550: Currently undocumented 551: 552: =cut 553: 554: ######################################### 555: ######################################### 556: sub get_all_text_unbalanced { 557: #there is a copy of this in lonxml.pm 558: my($tag,$pars)= @_; 559: my $token; 560: my $result=''; 561: $tag='<'.$tag.'>'; 562: while ($token = $$pars[-1]->get_token) { 563: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) { 564: $result.=$token->[1]; 565: } elsif ($token->[0] eq 'PI') { 566: $result.=$token->[2]; 567: } elsif ($token->[0] eq 'S') { 568: $result.=$token->[4]; 569: } elsif ($token->[0] eq 'E') { 570: $result.=$token->[2]; 571: } 572: if ($result =~ /(.*)\Q$tag\E(.*)/s) { 573: #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2); 574: #&Apache::lonnet::logthis('Result is :'.$1); 575: $result=$1; 576: my $redo=$tag.$2; 577: push (@$pars,HTML::LCParser->new(\$redo)); 578: $$pars[-1]->xml_mode('1'); 579: last; 580: } 581: } 582: return $result 583: } 584: 585: ######################################### 586: ######################################### 587: 588: =pod 589: 590: =item B<fix_ids_and_indices> 591: 592: Currently undocumented 593: 594: =cut 595: 596: ######################################### 597: ######################################### 598: #Arguably this should all be done as a lonnet::ssi instead 599: sub fix_ids_and_indices { 600: my ($logfile,$source,$target)=@_; 601: 602: my %allow; 603: my $content; 604: { 605: my $org=Apache::File->new($source); 606: $content=join('',<$org>); 607: } 608: 609: my ($needsfixup,$maxid,$maxindex,$duplicateids,@duplicatedids)= 610: &get_max_ids_indices(\$content); 611: 612: print $logfile ("Got $needsfixup,$maxid,$maxindex,$duplicateids--". 613: join(', ',@duplicatedids)); 614: if ($duplicateids) { 615: print $logfile "Duplicate ID(s) exist, ".join(', ',@duplicatedids)."\n"; 616: my $outstring=''.&mt('Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are').': '.join(', ',@duplicatedids).''; 617: return ($outstring,1); 618: } 619: if ($needsfixup) { 620: print $logfile "Needs ID and/or index fixup\n". 621: "Max ID : $maxid (min 10)\n". 622: "Max Index: $maxindex (min 10)\n"; 623: } 624: my $outstring=''; 625: my @parser; 626: $parser[0]=HTML::LCParser->new(\$content); 627: $parser[-1]->xml_mode(1); 628: my $token; 629: while (@parser) { 630: while ($token=$parser[-1]->get_token) { 631: if ($token->[0] eq 'S') { 632: my $counter; 633: my $tag=$token->[1]; 634: my $lctag=lc($tag); 635: if ($lctag eq 'allow') { 636: $allow{$token->[2]->{'src'}}=1; 637: next; 638: } 639: my %parms=%{$token->[2]}; 640: $counter=$addid{$tag}; 641: if (!$counter) { $counter=$addid{$lctag}; } 642: if ($counter) { 643: if ($counter eq 'id') { 644: unless (defined($parms{'id'})) { 645: $maxid++; 646: $parms{'id'}=$maxid; 647: print $logfile 'ID: '.$tag.':'.$maxid."\n"; 648: } 649: } elsif ($counter eq 'index') { 650: unless (defined($parms{'index'})) { 651: $maxindex++; 652: $parms{'index'}=$maxindex; 653: print $logfile 'Index: '.$tag.':'.$maxindex."\n"; 654: } 655: } 656: } 657: foreach my $type ('src','href','background','bgimg') { 658: foreach my $key (keys(%parms)) { 659: if ($key =~ /^$type$/i) { 660: $parms{$key}=&set_allow(\%allow,$logfile, 661: $target,$tag, 662: $parms{$key}); 663: } 664: } 665: } 666: # probably a <randomlabel> image type <label> 667: # or a <image> tag inside <imageresponse> 668: if (($lctag eq 'label' && defined($parms{'description'})) 669: || 670: ($lctag eq 'image')) { 671: my $next_token=$parser[-1]->get_token(); 672: if ($next_token->[0] eq 'T') { 673: $next_token->[1]=&set_allow(\%allow,$logfile, 674: $target,$tag, 675: $next_token->[1]); 676: } 677: $parser[-1]->unget_token($next_token); 678: } 679: if ($lctag eq 'applet') { 680: my $codebase=''; 681: my $havecodebase=0; 682: foreach my $key (keys(%parms)) { 683: if (lc($key) eq 'codebase') { 684: $codebase=$parms{$key}; 685: $havecodebase=1; 686: } 687: } 688: if ($havecodebase) { 689: my $oldcodebase=$codebase; 690: unless ($oldcodebase=~/\/$/) { 691: $oldcodebase.='/'; 692: } 693: $codebase=&urlfixup($oldcodebase,$target); 694: $codebase=~s/\/$//; 695: if ($codebase ne $oldcodebase) { 696: $parms{'codebase'}=$codebase; 697: print $logfile 'URL codebase: '.$tag.':'. 698: $oldcodebase.' - '. 699: $codebase."\n"; 700: } 701: $allow{&absoluteurl($codebase,$target).'/*'}=1; 702: } else { 703: foreach my $key (keys(%parms)) { 704: if ($key =~ /(archive|code|object)/i) { 705: my $oldurl=$parms{$key}; 706: my $newurl=&urlfixup($oldurl,$target); 707: $newurl=~s/\/[^\/]+$/\/\*/; 708: print $logfile 'Allow: applet '.lc($key).':'. 709: $oldurl.' allows '.$newurl."\n"; 710: $allow{&absoluteurl($newurl,$target)}=1; 711: } 712: } 713: } 714: } 715: my $newparmstring=''; 716: my $endtag=''; 717: foreach (keys %parms) { 718: if ($_ eq '/') { 719: $endtag=' /'; 720: } else { 721: my $quote=($parms{$_}=~/\"/?"'":'"'); 722: $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; 723: } 724: } 725: if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } 726: $outstring.='<'.$tag.$newparmstring.$endtag.'>'; 727: if ($lctag eq 'm' || $lctag eq 'script' 728: || $lctag eq 'display' || $lctag eq 'tex') { 729: $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser); 730: } 731: } elsif ($token->[0] eq 'E') { 732: if ($token->[2]) { 733: unless ($token->[1] eq 'allow') { 734: $outstring.='</'.$token->[1].'>'; 735: } 736: } 737: } else { 738: $outstring.=$token->[1]; 739: } 740: } 741: pop(@parser); 742: } 743: 744: if ($needsfixup) { 745: print $logfile "End of ID and/or index fixup\n". 746: "Max ID : $maxid (min 10)\n". 747: "Max Index: $maxindex (min 10)\n"; 748: } else { 749: print $logfile "Does not need ID and/or index fixup\n"; 750: } 751: 752: return ($outstring,0,%allow); 753: } 754: 755: ######################################### 756: ######################################### 757: 758: =pod 759: 760: =item B<store_metadata> 761: 762: Store the metadata in the metadata table in the loncapa database. 763: Uses lonmysql to access the database. 764: 765: Inputs: \%metadata 766: 767: Returns: (error,status). error is undef on success, status is undef on error. 768: 769: =cut 770: 771: ######################################### 772: ######################################### 773: sub store_metadata { 774: my %metadata = @_; 775: my $error; 776: # Determine if the table exists 777: my $status = &Apache::lonmysql::check_table('metadata'); 778: if (! defined($status)) { 779: $error='WARNING: Cannot connect to '. 780: 'database!'; 781: &Apache::lonnet::logthis($error); 782: return ($error,undef); 783: } 784: if ($status == 0) { 785: # It would be nice to actually create the table.... 786: $error ='WARNING: The metadata table does not '. 787: 'exist in the LON-CAPA database.'; 788: &Apache::lonnet::logthis($error); 789: return ($error,undef); 790: } 791: if (($metadata{'obsolete'}) || ($metadata{'copyright'} eq 'priv') || 792: ($metadata{'copyright'} eq 'custom')) { 793: # remove this entry 794: $status=&Apache::lonmysql::remove_from_table 795: ('metadata','url',$metadata{'url'}); 796: } else { 797: # store new data 798: # adjust some values to metadatadatabase (e.g., "usage" is a reserved word) 799: $metadata{'creationdate'}= 800: &Apache::lonmysql::sqltime($metadata{'creationdate'}); 801: $metadata{'lastrevisiondate'}= 802: &Apache::lonmysql::sqltime($metadata{'lastrevisiondate'}); 803: $metadata{'sequsage'}=$metadata{'usage'}; 804: $metadata{'sequsage_list'}=$metadata{'usage_list'}; 805: my %newmetadata=(); 806: # see if we have old entries 807: my @oldmeta=&Apache::lonmysql::get_rows('metadata', 808: "url LIKE BINARY '". 809: $metadata{'url'}."'"); 810: if ($#oldmeta==0) { 811: # yes, there is one old entry, transfer to newmetadata 812: %newmetadata=&Apache::lonmeta::metadata_col_to_hash(@{$oldmeta[0]}); 813: # remove old entry 814: $status=&Apache::lonmysql::remove_from_table 815: ('metadata','url',$metadata{'url'}); 816: } elsif ($#oldmeta>0) { 817: # more than one entry fit - how did that happen? 818: $error='Error occured retrieving old values in '. 819: 'metadata table in LON-CAPA database: '.$#oldmeta. 820: ' matches'; 821: &Apache::lonnet::logthis($error); 822: return ($error,undef); 823: } 824: # store new data on top of it 825: foreach (keys %metadata) { 826: $newmetadata{$_}=$metadata{$_}; 827: } 828: $status = &Apache::lonmysql::store_row('metadata',\%newmetadata); 829: } 830: if (! defined($status)) { 831: $error='Error occured storing new values in '. 832: 'metadata table in LON-CAPA database'; 833: &Apache::lonnet::logthis($error); 834: return ($error,undef); 835: } 836: return (undef,$status); 837: } 838: 839: 840: # ============================================== Parse file itself for metadata 841: # 842: # parses a file with target meta, sets global %metadatafields %metadatakeys 843: 844: sub parseformeta { 845: my ($source,$style)=@_; 846: my $allmeta=''; 847: if (($style eq 'ssi') || ($style eq 'prv')) { 848: my $dir=$source; 849: $dir=~s-/[^/]*$--; 850: my $file=$source; 851: $file=(split('/',$file))[-1]; 852: $source=&Apache::lonnet::hreflocation($dir,$file); 853: $allmeta=&Apache::lonnet::ssi_body($source,('grade_target' => 'meta')); 854: &metaeval($allmeta); 855: } 856: return $allmeta; 857: } 858: 859: ######################################### 860: ######################################### 861: 862: =pod 863: 864: =item B<publish> 865: 866: This is the workhorse function of this module. This subroutine generates 867: backup copies, performs any automatic processing (prior to publication, 868: especially for rat and ssi files), 869: 870: Returns a 2 element array, the first is the string to be shown to the 871: user, the second is an error code, either 1 (an error occured) or 0 872: (no error occurred) 873: 874: I<Additional documentation needed.> 875: 876: =cut 877: 878: ######################################### 879: ######################################### 880: sub publish { 881: 882: my ($source,$target,$style,$batch)=@_; 883: my $logfile; 884: my $scrout=''; 885: my $allmeta=''; 886: my $content=''; 887: my %allow=(); 888: 889: unless ($logfile=Apache::File->new('>>'.$source.'.log')) { 890: return (''.&mt('No write permission to user directory, FAIL').'',1); 891: } 892: print $logfile 893: "\n\n================= Publish ".localtime()." Phase One ================\n".$ENV{'user.name'}.'@'.$ENV{'user.domain'}."\n"; 894: 895: if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) { 896: # ------------------------------------------------------- This needs processing 897: 898: # ----------------------------------------------------------------- Backup Copy 899: my $copyfile=$source.'.save'; 900: if (copy($source,$copyfile)) { 901: print $logfile "Copied original file to ".$copyfile."\n"; 902: } else { 903: print $logfile "Unable to write backup ".$copyfile.':'.$!."\n"; 904: return ("Failed to write backup copy, $!,FAIL",1); 905: } 906: # ------------------------------------------------------------- IDs and indices 907: 908: my ($outstring,$error); 909: ($outstring,$error,%allow)=&fix_ids_and_indices($logfile,$source, 910: $target); 911: if ($error) { return ($outstring,$error); } 912: # ------------------------------------------------------------ Construct Allows 913: 914: $scrout.='<h3>'.&mt('Dependencies').'</h3>'; 915: my $allowstr=''; 916: foreach (sort(keys(%allow))) { 917: my $thisdep=$_; 918: if ($thisdep !~ /[^\s]/) { next; } 919: unless ($style eq 'rat') { 920: $allowstr.="\n".'<allow src="'.$thisdep.'" />'; 921: } 922: $scrout.=' '; 923: unless ($thisdep=~/\*/) { 924: $scrout.='<a href="'.$thisdep.'">'; 925: } 926: $scrout.='<tt>'.$thisdep.'</tt>'; 927: unless ($thisdep=~/\*/) { 928: $scrout.='</a>'; 929: if ( 930: &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. 931: $thisdep.'.meta') eq '-1') { 932: $scrout.= ' - '.&mt('Currently not available'). 933: ''; 934: } else { 935: my %temphash=(&Apache::lonnet::declutter($target).'___'. 936: &Apache::lonnet::declutter($thisdep).'___usage' 937: => time); 938: $thisdep=~/^\/res\/(\w+)\/(\w+)\//; 939: if ((defined($1)) && (defined($2))) { 940: &Apache::lonnet::put('nohist_resevaldata',\%temphash, 941: $1,$2); 942: } 943: } 944: } 945: } 946: $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s; 947: 948: ### FIXME: is this really what we want? 949: # I dont' think so, to will corrupt any UTF-8 resources at least, 950: # and any encoding other than ISO-8859-1 will probably break 951: #Encode any High ASCII characters 952: #$outstring=&HTML::Entities::encode($outstring,"\200-\377"); 953: # ------------------------------------------------------------- Write modified. 954: 955: { 956: my $org; 957: unless ($org=Apache::File->new('>'.$source)) { 958: print $logfile "No write permit to $source\n"; 959: return (''.&mt('No write permission to'). 960: ' '.$source. 961: ', '.&mt('FAIL').'',1); 962: } 963: print($org $outstring); 964: } 965: $content=$outstring; 966: 967: } 968: # -------------------------------------------- Initial step done, now metadata. 969: 970: # --------------------------------------- Storage for metadata keys and fields. 971: # these are globals 972: # 973: %metadatafields=(); 974: %metadatakeys=(); 975: 976: my %oldparmstores=(); 977: 978: unless ($batch) { 979: $scrout.='<h3>'.&mt('Metadata Information').' ' . 980: Apache::loncommon::help_open_topic("Metadata_Description") 981: . '</h3>'; 982: } 983: 984: # ------------------------------------------------ First, check out environment 985: unless (-e $source.'.meta') { 986: $metadatafields{'author'}=$ENV{'environment.firstname'}.' '. 987: $ENV{'environment.middlename'}.' '. 988: $ENV{'environment.lastname'}.' '. 989: $ENV{'environment.generation'}; 990: $metadatafields{'author'}=~s/\s+/ /g; 991: $metadatafields{'author'}=~s/\s+$//; 992: $metadatafields{'owner'}=$cuname.'@'.$cudom; 993: 994: # ------------------------------------------------ Check out directory hierachy 995: 996: my $thisdisfn=$source; 997: $thisdisfn=~s/^\/home\/\Q$cuname\E\///; 998: 999: my @urlparts=split(/\//,$thisdisfn); 1000: $#urlparts--; 1001: 1002: my $currentpath='/home/'.$cuname.'/'; 1003: 1004: my $prefix='../'x($#urlparts); 1005: foreach (@urlparts) { 1006: $currentpath.=$_.'/'; 1007: $scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix); 1008: $prefix=~s|^\.\./||; 1009: } 1010: # ----------------------------------------------------------- Parse file itself 1011: # read %metadatafields from file itself 1012: 1013: $allmeta=&parseformeta($source,$style); 1014: 1015: # ------------------- Clear out parameters and stores (there should not be any) 1016: 1017: foreach (keys %metadatafields) { 1018: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1019: delete $metadatafields{$_}; 1020: } 1021: } 1022: 1023: } else { 1024: # ---------------------- Read previous metafile, remember parameters and stores 1025: 1026: $scrout.=&metaread($logfile,$source.'.meta'); 1027: 1028: foreach (keys %metadatafields) { 1029: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1030: $oldparmstores{$_}=1; 1031: delete $metadatafields{$_}; 1032: } 1033: } 1034: # ------------------------------------------ See if anything new in file itself 1035: 1036: $allmeta=&parseformeta($source,$style); 1037: 1038: } 1039: 1040: 1041: # ---------------- Find and document discrepancies in the parameters and stores 1042: 1043: my $chparms=''; 1044: foreach (sort keys %metadatafields) { 1045: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1046: unless ($_=~/\.\w+$/) { 1047: unless ($oldparmstores{$_}) { 1048: print $logfile 'New: '.$_."\n"; 1049: $chparms.=$_.' '; 1050: } 1051: } 1052: } 1053: } 1054: if ($chparms) { 1055: $scrout.=''.&mt('New parameters or stored values'). 1056: ': '.$chparms.''; 1057: } 1058: 1059: $chparms=''; 1060: foreach (sort keys %oldparmstores) { 1061: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1062: unless (($metadatafields{$_.'.name'}) || 1063: ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { 1064: print $logfile 'Obsolete: '.$_."\n"; 1065: $chparms.=$_.' '; 1066: } 1067: } 1068: } 1069: if ($chparms) { 1070: $scrout.=''.&mt('Obsolete parameters or stored values').': '. 1071: $chparms.'<h1>'.&mt('Warning!'). 1072: '</h1>'. 1073: &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').'<hr />'; 1074: } 1075: 1076: # ------------------------------------------------------- Now have all metadata 1077: 1078: my %keywords=(); 1079: 1080: if (length($content)<500000) { 1081: my $textonly=$content; 1082: $textonly=~s/\<script[^\<]+\<\/script\>//g; 1083: $textonly=~s/\<m\>[^\<]+\<\/m\>//g; 1084: $textonly=~s/\<[^\>]*\>//g; 1085: $textonly=~tr/A-Z/a-z/; 1086: $textonly=~s/[\$\&][a-z]\w*//g; 1087: $textonly=~s/[^a-z\s]//g; 1088: 1089: foreach ($textonly=~m/(\w+)/g) { 1090: unless ($nokey{$_}) { 1091: $keywords{$_}=1; 1092: } 1093: } 1094: } 1095: 1096: 1097: foreach (split(/\W+/,$metadatafields{'keywords'})) { 1098: $keywords{$_}=1; 1099: } 1100: # --------------------------------------------------- Now we also have keywords 1101: # ============================================================================= 1102: # INTERACTIVE MODE 1103: # 1104: unless ($batch) { 1105: $scrout.= 1106: '<form name="pubform" action="/adm/publish" method="post">'. 1107: '<input type="submit" value="'.&mt('Finalize Publication').'" />'. 1108: &hiddenfield('phase','two'). 1109: &hiddenfield('filename',$ENV{'form.filename'}). 1110: &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)). 1111: &hiddenfield('dependencies',join(',',keys %allow)). 1112: &textfield('Title','title',$metadatafields{'title'}). 1113: &textfield('Author(s)','author',$metadatafields{'author'}). 1114: &textfield('Subject','subject',$metadatafields{'subject'}); 1115: 1116: # --------------------------------------------------- Scan content for keywords 1117: 1118: my $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords"); 1119: my $KEYWORDS=&mt('Keywords'); 1120: my $CheckAll=&mt('check all'); 1121: my $UncheckAll=&mt('uncheck all'); 1122: my $keywordout=<<"END"; 1123: <script> 1124: function checkAll(field) { 1125: for (i = 0; i < field.length; i++) 1126: field[i].checked = true ; 1127: } 1128: 1129: function uncheckAll(field) { 1130: for (i = 0; i < field.length; i++) 1131: field[i].checked = false ; 1132: } 1133: </script> 1134: $KEYWORDS: 1135: $keywords_help 1136: <input type="button" value="$CheckAll" onclick="javascript:checkAll(document.pubform.keywords)" /> 1137: <input type="button" value="$UncheckAll" onclick="javascript:uncheckAll(document.pubform.keywords)" /> 1138: 1139: 1140: END 1141: $keywordout.='<table border="2"><tr>'; 1142: my $colcount=0; 1143: 1144: foreach (sort keys %keywords) { 1145: $keywordout.='<td><input type="checkbox" name="keywords" value="'.$_.'"'; 1146: if ($metadatafields{'keywords'}) { 1147: if ($metadatafields{'keywords'}=~/\Q$_\E/) { 1148: $keywordout.=' checked="on"'; 1149: } 1150: } elsif (&Apache::loncommon::keyword($_)) { 1151: $keywordout.=' checked="on"'; 1152: } 1153: $keywordout.=' />'.$_.'</td>'; 1154: if ($colcount>10) { 1155: $keywordout.="</tr><tr>\n"; 1156: $colcount=0; 1157: } 1158: $colcount++; 1159: } 1160: 1161: $keywordout.='</tr></table>'; 1162: 1163: $scrout.=$keywordout; 1164: 1165: $scrout.=&textfield('Additional Keywords','addkey',''); 1166: 1167: $scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); 1168: 1169: $scrout.= 1170: "\n".&mt('Abstract').":". 1171: " ". 1172: '<textarea cols="80" rows="5" name="abstract">'. 1173: $metadatafields{'abstract'}.'</textarea>'; 1174: 1175: $source=~/\.(\w+)$/; 1176: 1177: 1178: $scrout.= 1179: "\n". 1180: &mt('Lowest Grade Level').':'. 1181: " ". 1182: &Apache::loncommon::select_level_form($metadatafields{'lowestgradelevel'},'lowestgradelevel'). 1183: "\n". 1184: &mt('Highest Grade Level').':'. 1185: " ". 1186: &Apache::loncommon::select_level_form($metadatafields{'highestgradelevel'},'highestgradelevel'). 1187: &textfield('Standards','standards',$metadatafields{'standards'}); 1188: 1189: 1190: 1191: 1192: $scrout.=&hiddenfield('mime',$1); 1193: 1194: my $defaultlanguage=$metadatafields{'language'}; 1195: $defaultlanguage =~ s/\s*notset\s*//g; 1196: $defaultlanguage =~ s/^,\s*//g; 1197: $defaultlanguage =~ s/,\s*$//g; 1198: 1199: $scrout.=&selectbox('Language','language', 1200: $defaultlanguage, 1201: \&Apache::loncommon::languagedescription, 1202: (&Apache::loncommon::languageids), 1203: ); 1204: 1205: unless ($metadatafields{'creationdate'}) { 1206: $metadatafields{'creationdate'}=time; 1207: } 1208: $scrout.=&hiddenfield('creationdate', 1209: &Apache::lonmysql::unsqltime($metadatafields{'creationdate'})); 1210: 1211: $scrout.=&hiddenfield('lastrevisiondate',time); 1212: 1213: 1214: $scrout.=&textfield('Publisher/Owner','owner', 1215: $metadatafields{'owner'}); 1216: 1217: # -------------------------------------------------- Correct copyright for rat. 1218: my $defaultoption=$metadatafields{'copyright'}; 1219: unless ($defaultoption) { $defaultoption='default'; } 1220: unless ($style eq 'prv') { 1221: if ($style eq 'rat') { 1222: if ($metadatafields{'copyright'} eq 'public') { 1223: delete $metadatafields{'copyright'}; 1224: $defaultoption='default'; 1225: } 1226: $scrout.=&selectbox('Copyright/Distribution','copyright', 1227: $defaultoption, 1228: \&Apache::loncommon::copyrightdescription, 1229: (grep !/^public$/,(&Apache::loncommon::copyrightids))); 1230: } else { 1231: $scrout.=&selectbox('Copyright/Distribution','copyright', 1232: $defaultoption, 1233: \&Apache::loncommon::copyrightdescription, 1234: (&Apache::loncommon::copyrightids)); 1235: } 1236: 1237: my $copyright_help = 1238: Apache::loncommon::help_open_topic('Publishing_Copyright'); 1239: $scrout =~ s/DISTRIBUTION:/'DISTRIBUTION: ' . $copyright_help/ge; 1240: $scrout.=&textfield('Custom Distribution File','customdistributionfile', 1241: $metadatafields{'customdistributionfile'}). 1242: $copyright_help; 1243: my $uctitle=&mt('Obsolete'); 1244: $scrout.= 1245: "\n$uctitle:". 1246: ' <input type="checkbox" name="obsolete" '; 1247: if ($metadatafields{'obsolete'}) { 1248: $scrout.=' checked="1" '; 1249: } 1250: $scrout.='/ >'. 1251: &textfield('Suggested Replacement for Obsolete File', 1252: 'obsoletereplacement', 1253: $metadatafields{'obsoletereplacement'}); 1254: } else { 1255: $scrout.=&hiddenfield('copyright','private'); 1256: } 1257: return ($scrout.'<input type="submit" value="'. 1258: &mt('Finalize Publication').'" /></form>',0); 1259: # ============================================================================= 1260: # BATCH MODE 1261: # 1262: } else { 1263: # Transfer metadata directly to environment for stage 2 1264: foreach (keys %metadatafields) { 1265: $ENV{'form.'.$_}=$metadatafields{$_}; 1266: } 1267: $ENV{'form.addkey'}=''; 1268: $ENV{'form.keywords'}=''; 1269: foreach (keys %keywords) { 1270: if ($metadatafields{'keywords'}) { 1271: if ($metadatafields{'keywords'}=~/\Q$_\E/) { 1272: $ENV{'form.keywords'}.=$_.','; 1273: } 1274: } elsif (&Apache::loncommon::keyword($_)) { 1275: $ENV{'form.keywords'}.=$_.','; 1276: } 1277: } 1278: $ENV{'form.keywords'}=~s/\,$//; 1279: unless ($ENV{'form.creationdate'}) { $ENV{'form.creationdate'}=time; } 1280: $ENV{'form.lastrevisiondate'}=time; 1281: if ((($style eq 'rat') && ($ENV{'form.copyright'} eq 'public')) || 1282: (!$ENV{'form.copyright'})) { 1283: $ENV{'form.copyright'}='default'; 1284: } 1285: $ENV{'form.allmeta'}=&Apache::lonnet::escape($allmeta); 1286: return ($scrout,0); 1287: } 1288: } 1289: 1290: ######################################### 1291: ######################################### 1292: 1293: =pod 1294: 1295: =item B<phasetwo> 1296: 1297: Render second interface showing status of publication steps. 1298: This is publication step two. 1299: 1300: Parameters: 1301: 1302: =over 4 1303: 1304: =item I<$source> 1305: 1306: =item I<$target> 1307: 1308: =item I<$style> 1309: 1310: =item I<$distarget> 1311: 1312: =back 1313: 1314: Returns: 1315: 1316: =over 4 1317: 1318: =item Scalar string 1319: 1320: String contains status (errors and warnings) and information associated with 1321: the server's attempts at publication. 1322: 1323: =cut 1324: 1325: #'stupid emacs 1326: ######################################### 1327: ######################################### 1328: sub phasetwo { 1329: 1330: my ($r,$source,$target,$style,$distarget,$batch)=@_; 1331: $source=~s/\/+/\//g; 1332: $target=~s/\/+/\//g; 1333: 1334: if ($target=~/\_\_\_/) { 1335: $r->print( 1336: ''.&mt('Unsupported character combination'). 1337: ' "<tt>___</tt>" '.&mt('in filename, FAIL').''); 1338: return 0; 1339: } 1340: $distarget=~s/\/+/\//g; 1341: my $logfile; 1342: unless ($logfile=Apache::File->new('>>'.$source.'.log')) { 1343: $r->print( 1344: ''. 1345: &mt('No write permission to user directory, FAIL').''); 1346: return 0; 1347: } 1348: print $logfile 1349: "\n================= Publish ".localtime()." Phase Two ================\n".$ENV{'user.name'}.'@'.$ENV{'user.domain'}."\n"; 1350: 1351: %metadatafields=(); 1352: %metadatakeys=(); 1353: 1354: &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'})); 1355: 1356: $metadatafields{'title'}=$ENV{'form.title'}; 1357: $metadatafields{'author'}=$ENV{'form.author'}; 1358: $metadatafields{'subject'}=$ENV{'form.subject'}; 1359: $metadatafields{'notes'}=$ENV{'form.notes'}; 1360: $metadatafields{'abstract'}=$ENV{'form.abstract'}; 1361: $metadatafields{'mime'}=$ENV{'form.mime'}; 1362: $metadatafields{'language'}=$ENV{'form.language'}; 1363: $metadatafields{'creationdate'}=$ENV{'form.creationdate'}; 1364: $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'}; 1365: $metadatafields{'owner'}=$ENV{'form.owner'}; 1366: $metadatafields{'copyright'}=$ENV{'form.copyright'}; 1367: $metadatafields{'standards'}=$ENV{'form.standards'}; 1368: $metadatafields{'lowestgradelevel'}=$ENV{'form.lowestgradelevel'}; 1369: $metadatafields{'highestgradelevel'}=$ENV{'form.highestgradelevel'}; 1370: $metadatafields{'customdistributionfile'}= 1371: $ENV{'form.customdistributionfile'}; 1372: $metadatafields{'obsolete'}=$ENV{'form.obsolete'}; 1373: $metadatafields{'obsoletereplacement'}= 1374: $ENV{'form.obsoletereplacement'}; 1375: $metadatafields{'dependencies'}=$ENV{'form.dependencies'}; 1376: $metadatafields{'modifyinguser'}=$ENV{'user.name'}.'@'. 1377: $ENV{'user.domain'}; 1378: $metadatafields{'authorspace'}=$cuname.'@'.$cudom; 1379: 1380: my $allkeywords=$ENV{'form.addkey'}; 1381: if (exists($ENV{'form.keywords'})) { 1382: if (ref($ENV{'form.keywords'})) { 1383: $allkeywords .= ','.join(',',@{$ENV{'form.keywords'}}); 1384: } else { 1385: $allkeywords .= ','.$ENV{'form.keywords'}; 1386: } 1387: } 1388: $allkeywords=~s/\W+/\,/; 1389: $allkeywords=~s/^\,//; 1390: $metadatafields{'keywords'}=$allkeywords; 1391: 1392: # check if custom distribution file is specified 1393: if ($metadatafields{'copyright'} eq 'custom') { 1394: my $file=$metadatafields{'customdistributionfile'}; 1395: unless ($file=~/\.rights$/) { 1396: return 1397: ''.&mt('No valid custom distribution rights file specified, FAIL'). 1398: ''; 1399: } 1400: } 1401: { 1402: print $logfile "\nWrite metadata file for ".$source; 1403: my $mfh; 1404: unless ($mfh=Apache::File->new('>'.$source.'.meta')) { 1405: return 1406: ''.&mt('Could not write metadata, FAIL'). 1407: ''; 1408: } 1409: foreach (sort keys %metadatafields) { 1410: unless ($_=~/\./) { 1411: my $unikey=$_; 1412: $unikey=~/^([A-Za-z]+)/; 1413: my $tag=$1; 1414: $tag=~tr/A-Z/a-z/; 1415: print $mfh "\n\<$tag"; 1416: foreach (split(/\,/,$metadatakeys{$unikey})) { 1417: my $value=$metadatafields{$unikey.'.'.$_}; 1418: $value=~s/\"/\'\'/g; 1419: print $mfh ' '.$_.'="'.$value.'"'; 1420: } 1421: print $mfh '>'. 1422: &HTML::Entities::encode($metadatafields{$unikey}) 1423: .'</'.$tag.'>'; 1424: } 1425: } 1426: $r->print(''.&mt('Wrote Metadata').''); 1427: print $logfile "\nWrote metadata"; 1428: } 1429: 1430: # -------------------------------- Synchronize entry with SQL metadata database 1431: 1432: $metadatafields{'url'} = $distarget; 1433: $metadatafields{'version'} = 'current'; 1434: 1435: my ($error,$success) = &store_metadata(%metadatafields); 1436: if ($success) { 1437: $r->print(''.&mt('Synchronized SQL metadata database').''); 1438: print $logfile "\nSynchronized SQL metadata database"; 1439: } else { 1440: $r->print($error); 1441: print $logfile "\n".$error; 1442: } 1443: # --------------------------------------------- Delete author resource messages 1444: my $delresult=&Apache::lonmsg::del_url_author_res_msg($target); 1445: $r->print(''.&mt('Removing error messages:').' '.$delresult.''); 1446: print $logfile "\nRemoving error messages: $delresult"; 1447: # ----------------------------------------------------------- Copy old versions 1448: 1449: if (-e $target) { 1450: my $filename; 1451: my $maxversion=0; 1452: $target=~/(.*)\/([^\/]+)\.(\w+)$/; 1453: my $srcf=$2; 1454: my $srct=$3; 1455: my $srcd=$1; 1456: unless ($srcd=~/^\/home\/httpd\/html\/res/) { 1457: print $logfile "\nPANIC: Target dir is ".$srcd; 1458: return "Invalid target directory, FAIL"; 1459: } 1460: opendir(DIR,$srcd); 1461: while ($filename=readdir(DIR)) { 1462: if (-l $srcd.'/'.$filename) { 1463: unlink($srcd.'/'.$filename); 1464: unlink($srcd.'/'.$filename.'.meta'); 1465: } else { 1466: if ($filename=~/\Q$srcf\E\.(\d+)\.\Q$srct\E$/) { 1467: $maxversion=($1>$maxversion)?$1:$maxversion; 1468: } 1469: } 1470: } 1471: closedir(DIR); 1472: $maxversion++; 1473: $r->print('Creating old version '.$maxversion.''); 1474: print $logfile "\nCreating old version ".$maxversion."\n"; 1475: 1476: my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct; 1477: 1478: if (copy($target,$copyfile)) { 1479: print $logfile "Copied old target to ".$copyfile."\n"; 1480: $r->print(''.&mt('Copied old target file').''); 1481: } else { 1482: print $logfile "Unable to write ".$copyfile.':'.$!."\n"; 1483: return "".&mt('Failed to copy old target'). 1484: ", $!, ".&mt('FAIL').""; 1485: } 1486: 1487: # --------------------------------------------------------------- Copy Metadata 1488: 1489: $copyfile=$copyfile.'.meta'; 1490: 1491: if (copy($target.'.meta',$copyfile)) { 1492: print $logfile "Copied old target metadata to ".$copyfile."\n"; 1493: $r->print(''.&mt('Copied old metadata').'') 1494: } else { 1495: print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; 1496: if (-e $target.'.meta') { 1497: return 1498: "". 1499: &mt('Failed to write old metadata copy').", $!, ".&mt('FAIL').""; 1500: } 1501: } 1502: 1503: 1504: } else { 1505: $r->print(''.&mt('Initial version').''); 1506: print $logfile "\nInitial version"; 1507: } 1508: 1509: # ---------------------------------------------------------------- Write Source 1510: my $copyfile=$target; 1511: 1512: my @parts=split(/\//,$copyfile); 1513: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 1514: 1515: my $count; 1516: for ($count=5;$count<$#parts;$count++) { 1517: $path.="/$parts[$count]"; 1518: if ((-e $path)!=1) { 1519: print $logfile "\nCreating directory ".$path; 1520: $r->print(''.&mt('Created directory').' '.$parts[$count].''); 1521: mkdir($path,0777); 1522: } 1523: } 1524: 1525: if (copy($source,$copyfile)) { 1526: print $logfile "\nCopied original source to ".$copyfile."\n"; 1527: $r->print(''.&mt('Copied source file').''); 1528: } else { 1529: print $logfile "\nUnable to write ".$copyfile.':'.$!."\n"; 1530: return "". 1531: &mt('Failed to copy source').", $!, ".&mt('FAIL').""; 1532: } 1533: 1534: # --------------------------------------------------------------- Copy Metadata 1535: 1536: $copyfile=$copyfile.'.meta'; 1537: 1538: if (copy($source.'.meta',$copyfile)) { 1539: print $logfile "\nCopied original metadata to ".$copyfile."\n"; 1540: $r->print(''.&mt('Copied metadata').''); 1541: } else { 1542: print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n"; 1543: return 1544: "".&mt('Failed to write metadata copy').", $!, ".&mt('FAIL').""; 1545: } 1546: $r->rflush; 1547: # --------------------------------------------------- Send update notifications 1548: 1549: my @subscribed=&get_subscribed_hosts($target); 1550: foreach my $subhost (@subscribed) { 1551: $r->print(''.&mt('Notifying host').' '.$subhost.':');$r->rflush; 1552: print $logfile "\nNotifying host ".$subhost.':'; 1553: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); 1554: $r->print($reply.' ');$r->rflush; 1555: print $logfile $reply; 1556: } 1557: 1558: # ---------------------------------------- Send update notifications, meta only 1559: 1560: my @subscribedmeta=&get_subscribed_hosts("$target.meta"); 1561: foreach my $subhost (@subscribedmeta) { 1562: $r->print(''. 1563: &mt('Notifying host for metadata only').' '.$subhost.':');$r->rflush; 1564: print $logfile "\nNotifying host for metadata only ".$subhost.':'; 1565: my $reply=&Apache::lonnet::critical('update:'.$target.'.meta', 1566: $subhost); 1567: $r->print($reply.' ');$r->rflush; 1568: print $logfile $reply; 1569: } 1570: 1571: # --------------------------------------------------- Notify subscribed courses 1572: my %courses=&coursedependencies($target); 1573: my $now=time; 1574: foreach (keys %courses) { 1575: $r->print(''.&mt('Notifying course').' '.$_.':');$r->rflush; 1576: print $logfile "\nNotifying host ".$_.':'; 1577: my ($cdom,$cname)=split(/\_/,$_); 1578: my $reply=&Apache::lonnet::cput 1579: ('versionupdate',{$target => $now},$cdom,$cname); 1580: $r->print($reply.' ');$r->rflush; 1581: print $logfile $reply; 1582: } 1583: # ------------------------------------------------ Provide link to new resource 1584: unless ($batch) { 1585: my $thisdistarget=$target; 1586: $thisdistarget=~s/^\Q$docroot\E//; 1587: 1588: my $thissrc=$source; 1589: $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/; 1590: 1591: my $thissrcdir=$thissrc; 1592: $thissrcdir=~s/\/[^\/]+$/\//; 1593: 1594: 1595: $r->print( 1596: '<hr /><a href="'.$thisdistarget.'">'. 1597: &mt('View Published Version').'</a>'. 1598: '<a href="'.$thissrc.'">'. 1599: &mt('Back to Source').'</a>'. 1600: '<a href="'.$thissrcdir. 1601: '">'. 1602: &mt('Back to Source Directory').'</a>'); 1603: } 1604: return ''.&mt('Done').''; 1605: } 1606: 1607: ######################################### 1608: 1609: sub batchpublish { 1610: my ($r,$srcfile,$targetfile)=@_; 1611: #publication pollutes %ENV with form.* values 1612: my %oldENV=%ENV; 1613: $srcfile=~s/\/+/\//g; 1614: $targetfile=~s/\/+/\//g; 1615: my $thisdisfn=$srcfile; 1616: $thisdisfn=~s/\/home\/korte\/public_html\///; 1617: $srcfile=~s/\/+/\//g; 1618: 1619: my $docroot=$r->dir_config('lonDocRoot'); 1620: my $thisdistarget=$targetfile; 1621: $thisdistarget=~s/^\Q$docroot\E//; 1622: 1623: 1624: %metadatafields=(); 1625: %metadatakeys=(); 1626: $srcfile=~/\.(\w+)$/; 1627: my $thistype=$1; 1628: 1629: 1630: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); 1631: 1632: $r->print('<h2>'.&mt('Publishing').' <tt>'.$thisdisfn.'</tt></h2>'); 1633: 1634: # phase one takes 1635: # my ($source,$target,$style,$batch)=@_; 1636: my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1); 1637: $r->print(''.$outstring.''); 1638: # phase two takes 1639: # my ($source,$target,$style,$distarget,batch)=@_; 1640: # $ENV{'form.allmeta'},$ENV{'form.title'},$ENV{'form.author'},... 1641: if (!$error) { 1642: $r->print(''); 1643: &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1); 1644: $r->print(''); 1645: } 1646: %ENV=%oldENV; 1647: return ''; 1648: } 1649: 1650: ######################################### 1651: 1652: sub publishdirectory { 1653: my ($r,$fn,$thisdisfn)=@_; 1654: $fn=~s/\/+/\//g; 1655: $thisdisfn=~s/\/+/\//g; 1656: my $resdir= 1657: $Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$cudom.'/'.$cuname.'/'. 1658: $thisdisfn; 1659: $r->print('<h1>'.&mt('Directory').' <tt>'.$thisdisfn.'</tt></h1>'. 1660: &mt('Target').': <tt>'.$resdir.'</tt> '); 1661: 1662: my $dirptr=16384; # Mask indicating a directory in stat.cmode. 1663: 1664: opendir(DIR,$fn); 1665: my @files=sort(readdir(DIR)); 1666: foreach my $filename (@files) { 1667: my ($cdev,$cino,$cmode,$cnlink, 1668: $cuid,$cgid,$crdev,$csize, 1669: $catime,$cmtime,$cctime, 1670: $cblksize,$cblocks)=stat($fn.'/'.$filename); 1671: 1672: my $extension=''; 1673: if ($filename=~/\.(\w+)$/) { $extension=$1; } 1674: if ($cmode&$dirptr) { 1675: if (($filename!~/^\./) && ($ENV{'form.pubrec'})) { 1676: &publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename); 1677: } 1678: } elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') && 1679: ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) { 1680: # find out publication status and/or exiting metadata 1681: my $publishthis=0; 1682: if (-e $resdir.'/'.$filename) { 1683: my ($rdev,$rino,$rmode,$rnlink, 1684: $ruid,$rgid,$rrdev,$rsize, 1685: $ratime,$rmtime,$rctime, 1686: $rblksize,$rblocks)=stat($resdir.'/'.$filename); 1687: if (($rmtime<$cmtime) || ($ENV{'form.forcerepub'})) { 1688: # previously published, modified now 1689: $publishthis=1; 1690: } 1691: } else { 1692: # never published 1693: $publishthis=1; 1694: } 1695: if ($publishthis) { 1696: &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename); 1697: } else { 1698: $r->print(' '.&mt('Skipping').' '.$filename.' '); 1699: } 1700: $r->rflush(); 1701: } 1702: } 1703: closedir(DIR); 1704: } 1705: 1706: ######################################### 1707: # publish a default.meta file 1708: 1709: sub defaultmetapublish { 1710: my ($r,$fn,$cuname,$cudom)=@_; 1711: $fn=~s/^\/\~$cuname\//\/home\/$cuname\/public_html\//; 1712: unless (-e $fn) { 1713: return HTTP_NOT_FOUND; 1714: } 1715: my $target=$fn; 1716: $target=~s/^\/home\/$cuname\/public_html\//$Apache::lonnet::perlvar{'lonDocRoot'}\/res\/$cudom\/$cuname\//; 1717: 1718: 1719: &Apache::loncommon::content_type($r,'text/html'); 1720: $r->send_http_header; 1721: 1722: $r->print('<html><head><title>LON-CAPA Publishing</title></head>'); 1723: $r->print(&Apache::loncommon::bodytag('Catalog Information Publication')); 1724: 1725: # ---------------------------------------------------------------- Write Source 1726: my $copyfile=$target; 1727: 1728: my @parts=split(/\//,$copyfile); 1729: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 1730: 1731: my $count; 1732: for ($count=5;$count<$#parts;$count++) { 1733: $path.="/$parts[$count]"; 1734: if ((-e $path)!=1) { 1735: $r->print(''.&mt('Created directory').' '.$parts[$count].''); 1736: mkdir($path,0777); 1737: } 1738: } 1739: 1740: if (copy($fn,$copyfile)) { 1741: $r->print(''.&mt('Copied source file').''); 1742: } else { 1743: return "". 1744: &mt('Failed to copy source').", $!, ".&mt('FAIL').""; 1745: } 1746: 1747: # --------------------------------------------------- Send update notifications 1748: 1749: my @subscribed=&get_subscribed_hosts($target); 1750: foreach my $subhost (@subscribed) { 1751: $r->print(''.&mt('Notifying host').' '.$subhost.':');$r->rflush; 1752: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); 1753: $r->print($reply.' ');$r->rflush; 1754: } 1755: # ------------------------------------------------------------------- Link back 1756: my $link=$fn; 1757: $link=~s/^\/home\/$cuname\/public_html\//\/priv\/$cuname\//; 1758: $r->print("<a href='$link'>".&mt('Back to Catalog Information').'</a>'); 1759: $r->print('</body></html>'); 1760: return OK; 1761: } 1762: ######################################### 1763: 1764: =pod 1765: 1766: =item B<handler> 1767: 1768: A basic outline of the handler subroutine follows. 1769: 1770: =over 4 1771: 1772: =item * 1773: 1774: Get query string for limited number of parameters. 1775: 1776: =item * 1777: 1778: Check filename. 1779: 1780: =item * 1781: 1782: File is there and owned, init lookup tables. 1783: 1784: =item * 1785: 1786: Start page output. 1787: 1788: =item * 1789: 1790: Evaluate individual file, and then output information. 1791: 1792: =item * 1793: 1794: Publishing from $thisfn to $thistarget with $thisembstyle. 1795: 1796: =back 1797: 1798: =cut 1799: 1800: ######################################### 1801: ######################################### 1802: sub handler { 1803: my $r=shift; 1804: 1805: if ($r->header_only) { 1806: &Apache::loncommon::content_type($r,'text/html'); 1807: $r->send_http_header; 1808: return OK; 1809: } 1810: 1811: # Get query string for limited number of parameters 1812: 1813: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, 1814: ['filename']); 1815: 1816: # -------------------------------------------------------------- Check filename 1817: 1818: my $fn=&Apache::lonnet::unescape($ENV{'form.filename'}); 1819: 1820: ($cuname,$cudom)= 1821: &Apache::loncacc::constructaccess($fn,$r->dir_config('lonDefDomain')); 1822: 1823: # special publication: default.meta file 1824: if ($fn=~/\/default.meta$/) { 1825: return &defaultmetapublish($r,$fn,$cuname,$cudom); 1826: } 1827: $fn=~s/\.meta$//; 1828: 1829: unless ($fn) { 1830: $r->log_reason($cuname.' at '.$cudom. 1831: ' trying to publish empty filename', $r->filename); 1832: return HTTP_NOT_FOUND; 1833: } 1834: 1835: unless (($cuname) && ($cudom)) { 1836: $r->log_reason($cuname.' at '.$cudom. 1837: ' trying to publish file '.$ENV{'form.filename'}. 1838: ' ('.$fn.') - not authorized', 1839: $r->filename); 1840: return HTTP_NOT_ACCEPTABLE; 1841: } 1842: 1843: my $home=&Apache::lonnet::homeserver($cuname,$cudom); 1844: my $allowed=0; 1845: my @ids=&Apache::lonnet::current_machine_ids(); 1846: foreach my $id (@ids) { if ($id eq $home) { $allowed = 1; } } 1847: unless ($allowed) { 1848: $r->log_reason($cuname.' at '.$cudom. 1849: ' trying to publish file '.$ENV{'form.filename'}. 1850: ' ('.$fn.') - not homeserver ('.$home.')', 1851: $r->filename); 1852: return HTTP_NOT_ACCEPTABLE; 1853: } 1854: 1855: $fn=~s/^http\:\/\/[^\/]+//; 1856: $fn=~s/^\/\~(\w+)/\/home\/$1\/public_html/; 1857: 1858: my $targetdir=''; 1859: $docroot=$r->dir_config('lonDocRoot'); 1860: if ($1 ne $cuname) { 1861: $r->log_reason($cuname.' at '.$cudom. 1862: ' trying to publish unowned file '. 1863: $ENV{'form.filename'}.' ('.$fn.')', 1864: $r->filename); 1865: return HTTP_NOT_ACCEPTABLE; 1866: } else { 1867: $targetdir=$docroot.'/res/'.$cudom; 1868: } 1869: 1870: 1871: unless (-e $fn) { 1872: $r->log_reason($cuname.' at '.$cudom. 1873: ' trying to publish non-existing file '. 1874: $ENV{'form.filename'}.' ('.$fn.')', 1875: $r->filename); 1876: return HTTP_NOT_FOUND; 1877: } 1878: 1879: unless ($ENV{'form.phase'} eq 'two') { 1880: 1881: # -------------------------------- File is there and owned, init lookup tables. 1882: 1883: %addid=(); 1884: 1885: { 1886: my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab'); 1887: while (<$fh>=~/(\w+)\s+(\w+)/) { 1888: $addid{$1}=$2; 1889: } 1890: } 1891: 1892: %nokey=(); 1893: 1894: { 1895: my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); 1896: while (<$fh>) { 1897: my $word=$_; 1898: chomp($word); 1899: $nokey{$word}=1; 1900: } 1901: } 1902: 1903: } 1904: 1905: # ---------------------------------------------------------- Start page output. 1906: 1907: &Apache::loncommon::content_type($r,'text/html'); 1908: $r->send_http_header; 1909: 1910: $r->print('<html><head><title>LON-CAPA Publishing</title></head>'); 1911: $r->print(&Apache::loncommon::bodytag('Resource Publication')); 1912: 1913: 1914: my $thisfn=$fn; 1915: 1916: my $thistarget=$thisfn; 1917: 1918: $thistarget=~s/^\/home/$targetdir/; 1919: $thistarget=~s/\/public\_html//; 1920: 1921: my $thisdistarget=$thistarget; 1922: $thisdistarget=~s/^\Q$docroot\E//; 1923: 1924: my $thisdisfn=$thisfn; 1925: $thisdisfn=~s/^\/home\/\Q$cuname\E\/public_html\///; 1926: 1927: if ($fn=~/\/$/) { 1928: # -------------------------------------------------------- This is a directory 1929: &publishdirectory($r,$fn,$thisdisfn); 1930: $r->print('<hr>'.&mt('Done').' <a href="/priv/' 1931: .$cuname.'/'.$thisdisfn 1932: .'">'.&mt('Return to Directory').'</a>'); 1933: 1934: 1935: } else { 1936: # ---------------------- Evaluate individual file, and then output information. 1937: $thisfn=~/\.(\w+)$/; 1938: my $thistype=$1; 1939: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); 1940: $r->print('<h2>'.&mt('Publishing').' '. 1941: &Apache::loncommon::filedescription($thistype).' <tt>'); 1942: 1943: $r->print(<<ENDCAPTION); 1944: <a href='javascript:void(window.open("/~$cuname/$thisdisfn","cat","height=300,width=500,scrollbars=1,resizable=1,menubar=0,location=1"))'> 1945: $thisdisfn</a> 1946: ENDCAPTION 1947: $r->print('</tt></h2>'.&mt('Target').': <tt>'. 1948: $thisdistarget.'</tt> '); 1949: 1950: if (($cuname ne $ENV{'user.name'})||($cudom ne $ENV{'user.domain'})) { 1951: $r->print('<h3>'.&mt('Co-Author').': '. 1952: $cuname.&mt(' at ').$cudom.'</h3>'); 1953: } 1954: 1955: if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { 1956: $r->print(<<ENDDIFF); 1957: 1958: <a href='javascript:void(window.open("/adm/diff?filename=/~$cuname/$thisdisfn&versiontwo=priv","cat","height=300,width=500,scrollbars=1,resizable=1,menubar=0,location=1"))'> 1959: ENDDIFF 1960: $r->print(&mt('Diffs with Current Version').'</a> '); 1961: } 1962: 1963: # ------------------ Publishing from $thisfn to $thistarget with $thisembstyle. 1964: 1965: unless ($ENV{'form.phase'} eq 'two') { 1966: my ($outstring,$error)=&publish($thisfn,$thistarget,$thisembstyle); 1967: $r->print('<hr />'.$outstring); 1968: } else { 1969: $r->print('<hr />'. 1970: &phasetwo($r,$thisfn,$thistarget,$thisembstyle,$thisdistarget)); 1971: } 1972: } 1973: $r->print('</body></html>'); 1974: 1975: return OK; 1976: } 1977: 1978: 1; 1979: __END__ 1980: 1981: =pod 1982: 1983: =back 1984: 1985: =back 1986: 1987: =cut 1988: