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