loncom/publisher/lonpublisher.pm - view

File: [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.177: download - view: text, annotated - select for diffs
Wed Jul 7 21:23:31 2004 UTC (19 years, 10 months ago) by albertel
Branches: MAIN
CVS tags: version_1_2_X, version_1_2_1, version_1_2_0, version_1_1_99_5, version_1_1_99_4, version_1_1_99_3, version_1_1_99_2, HEAD

- BUG#3177, forgot to move some of the fix over

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