loncom/publisher/lonpublisher.pm - view

File: [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.239: download - view: text, annotated - select for diffs
Mon Jun 30 18:10:24 2008 UTC (15 years, 11 months ago) by bisitz
Branches: MAIN
CVS tags: version_2_6_99_0, HEAD

- Shortened main headline and added new sub headline "Resource Details"
- Wrapped resource details in LON-CAPA standard table
- Added info text which asks the author to fill in the metadata
- Added missing and optimzied some &mt() calls
- Moved Finalize/Make Obsolete buttons out of metadata table
- Optimized screen output with some <br /> and <p> tags
- Added error style to output "...document contains errors..."
- Extended output "...without responses..."

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