loncom/publisher/lonpublisher.pm - view

File: [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.294: download - view: text, annotated - select for diffs
Fri Dec 12 18:27:34 2014 UTC (9 years, 5 months ago) by raeburn
Branches: MAIN
CVS tags: version_2_11_3_uiuc, version_2_11_3_msu, version_2_11_3, version_2_11_2_uiuc, version_2_11_2_msu, version_2_11_2_educog, version_2_11_2, version_2_11_1, HEAD

- Coding style:
  - keys() sort()
  - for readability eliminate use of $_

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