loncom/publisher/lonpublisher.pm - view

File: [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.293: download - view: text, annotated - select for diffs
Sun Aug 3 14:20:38 2014 UTC (9 years, 10 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD

- Support style of packaging .js dependency used in Camtasia Studio 8.4.2
  *_player.html files.
- Dependency on spritesheet.min.css no longer included as <link> tag in
  Camtasia's top-levl *.html file, so explicitly include in %allow.

1: # The LearningOnline Network with CAPA 2: # Publication Handler 3: # 4: # $Id: lonpublisher.pm,v 1.293 2014/08/03 14:20:38 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 (@{$token->[3]}) { 204: $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; 205: if ($metadatakeys{$unikey}) { 206: $metadatakeys{$unikey}.=','.$_; 207: } else { 208: $metadatakeys{$unikey}=$_; 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 (keys %evaldata) { 297: if ($_=~/^([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 (@idlist) { 386: $selout.='<option value="'.$_.'"'; 387: if ($_ eq $value) { 388: $selout.=' selected="selected"'; 389: } 390: $selout.='>'.&{$functionref}($_).'</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 (keys %parms) { 791: if ($_ eq '/') { 792: $endtag=' /'; 793: } else { 794: my $quote=($parms{$_}=~/\"/?"'":'"'); 795: $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$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 (keys %metadatafields) { 1201: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1202: delete $metadatafields{$_}; 1203: } 1204: } 1205: 1206: } else { 1207: # ---------------------- Read previous metafile, remember parameters and stores 1208: 1209: $scrout.=&metaread($logfile,$source.'.meta'); 1210: 1211: foreach (keys %metadatafields) { 1212: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1213: $oldparmstores{$_}=1; 1214: delete $metadatafields{$_}; 1215: } 1216: } 1217: # ------------------------------------------------------------- Save some stuff 1218: my %savemeta=(); 1219: foreach ('title') { 1220: if ($metadatafields{$_}) { $savemeta{$_}=$metadatafields{$_}; } 1221: } 1222: # ------------------------------------------ See if anything new in file itself 1223: 1224: $allmeta=&parseformeta($source,$style); 1225: # ----------------------------------------------------------- Restore the stuff 1226: foreach (keys %savemeta) { 1227: $metadatafields{$_}=$savemeta{$_}; 1228: } 1229: } 1230: 1231: 1232: # ---------------- Find and document discrepancies in the parameters and stores 1233: 1234: my $chparms=''; 1235: foreach (sort keys %metadatafields) { 1236: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1237: unless ($_=~/\.\w+$/) { 1238: unless ($oldparmstores{$_}) { 1239: my $disp_key = $_; 1240: $disp_key =~ tr/\0/_/; 1241: print $logfile ('New: '.$disp_key."\n"); 1242: $chparms .= $disp_key.' '; 1243: } 1244: } 1245: } 1246: } 1247: if ($chparms) { 1248: $scrout.='<p><b>'.&mt('New parameters or saved values'). 1249: ':</b> '.$chparms.'</p>'; 1250: } 1251: 1252: $chparms=''; 1253: foreach (sort keys %oldparmstores) { 1254: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1255: unless (($metadatafields{$_.'.name'}) || 1256: ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { 1257: my $disp_key = $_; 1258: $disp_key =~ tr/\0/_/; 1259: print $logfile ('Obsolete: '.$disp_key."\n"); 1260: $chparms.=$disp_key.' '; 1261: } 1262: } 1263: } 1264: if ($chparms) { 1265: $scrout.='<p><b>'.&mt('Obsolete parameters or saved values').':</b> ' 1266: .$chparms.'</p>' 1267: .'<p class="LC_warning"><b>'.&mt('Warning!').'</b><br />' 1268: .&mt('If this resource is in active use, student performance data from the previous version may become inaccessible.') 1269: .'</p><hr />'; 1270: } 1271: if ($metadatafields{'copyright'} eq 'priv') { 1272: $scrout.='<p class="LC_warning"><b>'.&mt('Warning!').'</b><br />' 1273: .&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.') 1274: .'</p><hr />'; 1275: } 1276: 1277: # ------------------------------------------------------- Now have all metadata 1278: 1279: my %keywords=(); 1280: 1281: if (length($content)<500000) { 1282: my $textonly=$content; 1283: $textonly=~s/\<script[^\<]+\<\/script\>//g; 1284: $textonly=~s/\<m\>[^\<]+\<\/m\>//g; 1285: $textonly=~s/\<[^\>]*\>//g; 1286: 1287: #this is a work simplification for german authors for present 1288: $textonly=HTML::Entities::decode($textonly); #decode HTML-character 1289: $textonly=Encode::Encoder::encode('utf8', $textonly); #encode to perl internal unicode 1290: $textonly=~tr/A-ZÜÄÖ/a-züäö/; #add lowercase rule for german "Umlaute" 1291: $textonly=~s/[\$\&][a-z]\w*//g; 1292: $textonly=~s/[^a-z^ü^ä^ö^ß\s]//g; #dont delete german "Umlaute" 1293: 1294: foreach ($textonly=~m/[^\s]+/g) { #match all but whitespaces 1295: unless ($nokey{$_}) { 1296: $keywords{$_}=1; 1297: } 1298: } 1299: 1300: 1301: } 1302: 1303: foreach my $addkey (split(/[\"\'\,\;]/,$metadatafields{'keywords'})) { 1304: $addkey=~s/\s+/ /g; 1305: $addkey=~s/^\s//; 1306: $addkey=~s/\s$//; 1307: if ($addkey=~/\w/) { 1308: $keywords{$addkey}=1; 1309: } 1310: } 1311: # --------------------------------------------------- Now we also have keywords 1312: # ============================================================================= 1313: # interactive mode html goes into $intr_scrout 1314: # batch mode throws away this HTML 1315: # additionally all of the field functions have a by product of setting 1316: # $env{'from.'..} so that it can be used by the phase two handler in 1317: # batch mode 1318: 1319: my $intr_scrout.='<br />' 1320: .'<form name="pubform" action="/adm/publish" method="post">'; 1321: unless ($env{'form.makeobsolete'}) { 1322: $intr_scrout.='<p class="LC_warning">' 1323: .&mt('Searching for your resource will be based on the following metadata. Please provide as much data as possible.') 1324: .'</p>' 1325: .'<p><input type="submit" value="' 1326: .&mt('Finalize Publication') 1327: .'" /> <a href="'.&Apache::loncfile::url($source).'">'.&mt('Cancel').'</a></p>'; 1328: } 1329: $intr_scrout.=&Apache::lonhtmlcommon::start_pick_box(); 1330: $intr_scrout.= 1331: &hiddenfield('phase','two'). 1332: &hiddenfield('filename',$env{'form.filename'}). 1333: &hiddenfield('allmeta',&escape($allmeta)). 1334: &hiddenfield('dependencies',join(',',keys %allow)); 1335: unless ($env{'form.makeobsolete'}) { 1336: $intr_scrout.= 1337: &textfield('Title','title',$metadatafields{'title'}). 1338: &textfield('Author(s)','author',$metadatafields{'author'}). 1339: &textfield('Subject','subject',$metadatafields{'subject'}); 1340: # --------------------------------------------------- Scan content for keywords 1341: 1342: my $keywords_help = &Apache::loncommon::help_open_topic("Publishing_Keywords"); 1343: my $keywordout=<<"END"; 1344: <script> 1345: function checkAll(field) { 1346: for (i = 0; i < field.length; i++) 1347: field[i].checked = true ; 1348: } 1349: 1350: function uncheckAll(field) { 1351: for (i = 0; i < field.length; i++) 1352: field[i].checked = false ; 1353: } 1354: </script> 1355: END 1356: $keywordout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Keywords')) 1357: .$keywords_help 1358: .'<input type="button" value="'.&mt('check all').'" onclick="javascript:checkAll(document.pubform.keywords)" />' 1359: .'<input type="button" value="'.&mt('uncheck all').'" onclick="javascript:uncheckAll(document.pubform.keywords)" />' 1360: .'</p><br />' 1361: .&Apache::loncommon::start_data_table(); 1362: my $cols_per_row = 10; 1363: my $colcount=0; 1364: my $wordcount=0; 1365: my $numkeywords = scalar(keys(%keywords)); 1366: 1367: foreach my $word (sort(keys(%keywords))) { 1368: if ($colcount == 0) { 1369: $keywordout .= &Apache::loncommon::start_data_table_row(); 1370: } 1371: $colcount++; 1372: $wordcount++; 1373: if (($wordcount == $numkeywords) && ($colcount < $cols_per_row)) { 1374: my $colspan = 1+$cols_per_row-$colcount; 1375: $keywordout .= '<td colspan="'.$colspan.'">'; 1376: } else { 1377: $keywordout .= '<td>'; 1378: } 1379: $keywordout.='<label><input type="checkbox" name="keywords" value="'.$word.'"'; 1380: if ($metadatafields{'keywords'}) { 1381: if ($metadatafields{'keywords'}=~/\Q$word\E/) { 1382: $keywordout.=' checked="checked"'; 1383: $env{'form.keywords'}.=$word.','; 1384: } 1385: } elsif (&Apache::loncommon::keyword($word)) { 1386: $keywordout.=' checked="checked"'; 1387: $env{'form.keywords'}.=$word.','; 1388: } 1389: $keywordout.=' />'.$word.'</label></td>'; 1390: if ($colcount == $cols_per_row) { 1391: $keywordout.=&Apache::loncommon::end_data_table_row(); 1392: $colcount=0; 1393: } 1394: } 1395: if ($colcount > 0) { 1396: $keywordout .= &Apache::loncommon::end_data_table_row(); 1397: } 1398: 1399: $env{'form.keywords'}=~s/\,$//; 1400: 1401: $keywordout.=&Apache::loncommon::end_data_table_row() 1402: .&Apache::loncommon::end_data_table() 1403: .&Apache::lonhtmlcommon::row_closure(); 1404: 1405: $intr_scrout.=$keywordout; 1406: 1407: $intr_scrout.=&textfield('Additional Keywords','addkey',''); 1408: 1409: $intr_scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); 1410: 1411: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Abstract')) 1412: .'<textarea cols="80" rows="5" name="abstract">' 1413: .$metadatafields{'abstract'} 1414: .'</textarea>' 1415: .&Apache::lonhtmlcommon::row_closure(); 1416: 1417: $source=~/\.(\w+)$/; 1418: 1419: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Grade Levels')) 1420: .&mt('Lowest Grade Level:').' ' 1421: .&select_level_form($metadatafields{'lowestgradelevel'},'lowestgradelevel') 1422: # .&Apache::lonhtmlcommon::row_closure(); 1423: # $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Highest Grade Level')) 1424: .' '.&mt('Highest Grade Level:').' ' 1425: .&select_level_form($metadatafields{'highestgradelevel'},'highestgradelevel') 1426: .&Apache::lonhtmlcommon::row_closure(); 1427: 1428: $intr_scrout.=&textfield('Standards','standards',$metadatafields{'standards'}); 1429: 1430: $intr_scrout.=&hiddenfield('mime',$1); 1431: 1432: my $defaultlanguage=$metadatafields{'language'}; 1433: $defaultlanguage =~ s/\s*notset\s*//g; 1434: $defaultlanguage =~ s/^,\s*//g; 1435: $defaultlanguage =~ s/,\s*$//g; 1436: 1437: $intr_scrout.=&selectbox('Language','language', 1438: $defaultlanguage, 1439: \&Apache::loncommon::languagedescription, 1440: (&Apache::loncommon::languageids), 1441: ); 1442: 1443: unless ($metadatafields{'creationdate'}) { 1444: $metadatafields{'creationdate'}=time; 1445: } 1446: $intr_scrout.=&hiddenfield('creationdate', 1447: &Apache::lonmysql::unsqltime($metadatafields{'creationdate'})); 1448: 1449: $intr_scrout.=&hiddenfield('lastrevisiondate',time); 1450: 1451: my $pubowner_last; 1452: if ($style eq 'prv') { 1453: $pubowner_last = 1; 1454: } 1455: $intr_scrout.=&textfield('Publisher/Owner','owner', 1456: $metadatafields{'owner'},$pubowner_last); 1457: 1458: # ---------------------------------------------- Retrofix for unused copyright 1459: if ($metadatafields{'copyright'} eq 'free') { 1460: $metadatafields{'copyright'}='default'; 1461: $metadatafields{'sourceavail'}='open'; 1462: } 1463: if ($metadatafields{'copyright'} eq 'priv') { 1464: $metadatafields{'copyright'}='domain'; 1465: } 1466: # ------------------------------------------------ Dial in reasonable defaults 1467: my $defaultoption=$metadatafields{'copyright'}; 1468: unless ($defaultoption) { $defaultoption='default'; } 1469: my $defaultsourceoption=$metadatafields{'sourceavail'}; 1470: unless ($defaultsourceoption) { $defaultsourceoption='closed'; } 1471: unless ($style eq 'prv') { 1472: # -------------------------------------------------- Correct copyright for rat. 1473: if ($style eq 'rat') { 1474: # -------------------------------------- Retrofix for non-applicable copyright 1475: if ($metadatafields{'copyright'} eq 'public') { 1476: delete $metadatafields{'copyright'}; 1477: $defaultoption='default'; 1478: } 1479: $intr_scrout.=&selectbox('Copyright/Distribution','copyright', 1480: $defaultoption, 1481: \&Apache::loncommon::copyrightdescription, 1482: (grep !/^(public|priv)$/,(&Apache::loncommon::copyrightids))); 1483: } else { 1484: $intr_scrout.=&selectbox('Copyright/Distribution','copyright', 1485: $defaultoption, 1486: \&Apache::loncommon::copyrightdescription, 1487: (grep !/^priv$/,(&Apache::loncommon::copyrightids))); 1488: } 1489: my $copyright_help = 1490: &Apache::loncommon::help_open_topic('Publishing_Copyright'); 1491: my $replace=&mt('Copyright/Distribution:'); 1492: $intr_scrout =~ s/$replace/$replace.' '.$copyright_help/ge; 1493: 1494: $intr_scrout.=&text_with_browse_field('Custom Distribution File','customdistributionfile',$metadatafields{'customdistributionfile'},'rights'); 1495: $intr_scrout.=&selectbox('Source Distribution','sourceavail', 1496: $defaultsourceoption, 1497: \&Apache::loncommon::source_copyrightdescription, 1498: (&Apache::loncommon::source_copyrightids)); 1499: # $intr_scrout.=&text_with_browse_field('Source Custom Distribution File','sourcerights',$metadatafields{'sourcerights'},'rights'); 1500: my $uctitle=&mt('Obsolete'); 1501: my $obsolete_checked=($metadatafields{'obsolete'})?' checked="checked"':''; 1502: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title($uctitle) 1503: .'<input type="checkbox" name="obsolete"'.$obsolete_checked.' />' 1504: .&Apache::lonhtmlcommon::row_closure(1); 1505: $intr_scrout.=&text_with_browse_field('Suggested Replacement for Obsolete File', 1506: 'obsoletereplacement', 1507: $metadatafields{'obsoletereplacement'},'',1); 1508: } else { 1509: $intr_scrout.=&hiddenfield('copyright','private'); 1510: } 1511: } else { 1512: $intr_scrout.= 1513: &hiddenfield('title',$metadatafields{'title'}). 1514: &hiddenfield('author',$metadatafields{'author'}). 1515: &hiddenfield('subject',$metadatafields{'subject'}). 1516: &hiddenfield('keywords',$metadatafields{'keywords'}). 1517: &hiddenfield('abstract',$metadatafields{'abstract'}). 1518: &hiddenfield('notes',$metadatafields{'notes'}). 1519: &hiddenfield('mime',$metadatafields{'mime'}). 1520: &hiddenfield('creationdate',$metadatafields{'creationdate'}). 1521: &hiddenfield('lastrevisiondate',time). 1522: &hiddenfield('owner',$metadatafields{'owner'}). 1523: &hiddenfield('lowestgradelevel',$metadatafields{'lowestgradelevel'}). 1524: &hiddenfield('standards',$metadatafields{'standards'}). 1525: &hiddenfield('highestgradelevel',$metadatafields{'highestgradelevel'}). 1526: &hiddenfield('language',$metadatafields{'language'}). 1527: &hiddenfield('copyright',$metadatafields{'copyright'}). 1528: &hiddenfield('sourceavail',$metadatafields{'sourceavail'}). 1529: &hiddenfield('customdistributionfile',$metadatafields{'customdistributionfile'}). 1530: &hiddenfield('obsolete',1). 1531: &text_with_browse_field('Suggested Replacement for Obsolete File', 1532: 'obsoletereplacement', 1533: $metadatafields{'obsoletereplacement'},'',1); 1534: } 1535: if (!$batch) { 1536: $scrout.=$intr_scrout 1537: .&Apache::lonhtmlcommon::end_pick_box() 1538: .'<p><input type="submit" value="' 1539: .&mt($env{'form.makeobsolete'}?'Make Obsolete':'Finalize Publication') 1540: .'" /></p>' 1541: .'</form>'; 1542: } 1543: return($scrout,0); 1544: } 1545: 1546: ######################################### 1547: ######################################### 1548: 1549: =pod 1550: 1551: =item B<phasetwo> 1552: 1553: Render second interface showing status of publication steps. 1554: This is publication step two. 1555: 1556: Parameters: 1557: 1558: =over 4 1559: 1560: =item I<$source> 1561: 1562: =item I<$target> 1563: 1564: =item I<$style> 1565: 1566: =item I<$distarget> 1567: 1568: =back 1569: 1570: Returns: 1571: 1572: =over 4 1573: 1574: =item integer 1575: 1576: 0: fail 1577: 1: success 1578: 1579: =back 1580: 1581: =cut 1582: 1583: #'stupid emacs 1584: ######################################### 1585: ######################################### 1586: sub phasetwo { 1587: 1588: my ($r,$source,$target,$style,$distarget,$batch)=@_; 1589: $source=~s/\/+/\//g; 1590: $target=~s/\/+/\//g; 1591: # 1592: # Unless trying to get rid of something, check name validity 1593: # 1594: unless ($env{'form.obsolete'}) { 1595: if ($target=~/(\_\_\_|\&\&\&|\:\:\:)/) { 1596: $r->print('<span class="LC_error">'. 1597: &mt('Unsupported character combination [_1] in filename, FAIL.',"<tt>'.$1.'</tt>"). 1598: '</span>'); 1599: return 0; 1600: } 1601: unless ($target=~/\.(\w+)$/) { 1602: $r->print('<span class="LC_error">'.&mt('No valid extension found in filename, FAIL').'</span>'); 1603: return 0; 1604: } 1605: if ($target=~/\.(\d+)\.(\w+)$/) { 1606: $r->print('<span class="LC_error">'.&mt('Filename of resource contains internal version number. Cannot publish such resources, FAIL').'</span>'); 1607: return 0; 1608: } 1609: } 1610: 1611: # 1612: # End name check 1613: # 1614: $distarget=~s/\/+/\//g; 1615: my $logfile; 1616: unless ($logfile=Apache::File->new('>>'.$source.'.log')) { 1617: $r->print( 1618: '<span class="LC_error">'. 1619: &mt('No write permission to user directory, FAIL').'</span>'); 1620: return 0; 1621: } 1622: 1623: if ($source =~ /\.rights$/) { 1624: $r->print('<p><span class="LC_warning">'.&mt('Warning: It can take up to 1 hour for rights changes to fully propagate.').'</span></p>'); 1625: } 1626: 1627: print $logfile 1628: "\n================= Publish ".localtime()." Phase Two ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n"; 1629: 1630: %metadatafields=(); 1631: %metadatakeys=(); 1632: 1633: &metaeval(&unescape($env{'form.allmeta'})); 1634: 1635: $metadatafields{'title'}=$env{'form.title'}; 1636: $metadatafields{'author'}=$env{'form.author'}; 1637: $metadatafields{'subject'}=$env{'form.subject'}; 1638: $metadatafields{'notes'}=$env{'form.notes'}; 1639: $metadatafields{'abstract'}=$env{'form.abstract'}; 1640: $metadatafields{'mime'}=$env{'form.mime'}; 1641: $metadatafields{'language'}=$env{'form.language'}; 1642: $metadatafields{'creationdate'}=$env{'form.creationdate'}; 1643: $metadatafields{'lastrevisiondate'}=$env{'form.lastrevisiondate'}; 1644: $metadatafields{'owner'}=$env{'form.owner'}; 1645: $metadatafields{'copyright'}=$env{'form.copyright'}; 1646: $metadatafields{'standards'}=$env{'form.standards'}; 1647: $metadatafields{'lowestgradelevel'}=$env{'form.lowestgradelevel'}; 1648: $metadatafields{'highestgradelevel'}=$env{'form.highestgradelevel'}; 1649: $metadatafields{'customdistributionfile'}= 1650: $env{'form.customdistributionfile'}; 1651: $metadatafields{'sourceavail'}=$env{'form.sourceavail'}; 1652: $metadatafields{'obsolete'}=$env{'form.obsolete'}; 1653: $metadatafields{'obsoletereplacement'}= 1654: $env{'form.obsoletereplacement'}; 1655: $metadatafields{'dependencies'}=$env{'form.dependencies'}; 1656: $metadatafields{'modifyinguser'}=$env{'user.name'}.':'. 1657: $env{'user.domain'}; 1658: $metadatafields{'authorspace'}=$cuname.':'.$cudom; 1659: $metadatafields{'domain'}=$cudom; 1660: 1661: my $allkeywords=$env{'form.addkey'}; 1662: if (exists($env{'form.keywords'})) { 1663: if (ref($env{'form.keywords'})) { 1664: $allkeywords .= ','.join(',',@{$env{'form.keywords'}}); 1665: } else { 1666: $allkeywords .= ','.$env{'form.keywords'}; 1667: } 1668: } 1669: $allkeywords=~s/[\"\']//g; 1670: $allkeywords=~s/\s*[\;\,]\s*/\,/g; 1671: $allkeywords=~s/\s+/ /g; 1672: $allkeywords=~s/^[ \,]//; 1673: $allkeywords=~s/[ \,]$//; 1674: $metadatafields{'keywords'}=$allkeywords; 1675: 1676: # check if custom distribution file is specified 1677: if ($metadatafields{'copyright'} eq 'custom') { 1678: my $file=$metadatafields{'customdistributionfile'}; 1679: unless ($file=~/\.rights$/) { 1680: $r->print( 1681: '<span class="LC_error">'.&mt('No valid custom distribution rights file specified, FAIL'). 1682: '</span>'); 1683: return 0; 1684: } 1685: } 1686: { 1687: print $logfile "\nWrite metadata file for ".$source; 1688: my $mfh; 1689: unless ($mfh=Apache::File->new('>'.$source.'.meta')) { 1690: $r->print( 1691: '<span class="LC_error">'.&mt('Could not write metadata, FAIL'). 1692: '</span>'); 1693: return 0; 1694: } 1695: foreach (sort keys %metadatafields) { 1696: unless ($_=~/\./) { 1697: my $unikey=$_; 1698: $unikey=~/^([A-Za-z]+)/; 1699: my $tag=$1; 1700: $tag=~tr/A-Z/a-z/; 1701: print $mfh "\n\<$tag"; 1702: foreach (split(/\,/,$metadatakeys{$unikey})) { 1703: my $value=$metadatafields{$unikey.'.'.$_}; 1704: $value=~s/\"/\'\'/g; 1705: print $mfh ' '.$_.'="'.$value.'"'; 1706: } 1707: print $mfh '>'. 1708: &HTML::Entities::encode($metadatafields{$unikey},'<>&"') 1709: .'</'.$tag.'>'; 1710: } 1711: } 1712: $r->print('<p>'.&mt('Wrote Metadata').'</p>'); 1713: print $logfile "\nWrote metadata"; 1714: } 1715: 1716: # -------------------------------- Synchronize entry with SQL metadata database 1717: 1718: $metadatafields{'url'} = $distarget; 1719: $metadatafields{'version'} = 'current'; 1720: 1721: my ($error,$success) = &store_metadata(%metadatafields); 1722: if ($success) { 1723: $r->print('<p>'.&mt('Synchronized SQL metadata database').'</p>'); 1724: print $logfile "\nSynchronized SQL metadata database"; 1725: } else { 1726: $r->print($error); 1727: print $logfile "\n".$error; 1728: } 1729: # --------------------------------------------- Delete author resource messages 1730: my $delresult=&Apache::lonmsg::del_url_author_res_msg($target); 1731: $r->print('<p>'.&mt('Removing error messages:').' '.$delresult.'</p>'); 1732: print $logfile "\nRemoving error messages: $delresult"; 1733: # ----------------------------------------------------------- Copy old versions 1734: 1735: if (-e $target) { 1736: my $filename; 1737: my $maxversion=0; 1738: $target=~/(.*)\/([^\/]+)\.(\w+)$/; 1739: my $srcf=$2; 1740: my $srct=$3; 1741: my $srcd=$1; 1742: my $docroot = $Apache::lonnet::perlvar{'lonDocRoot'}; 1743: unless ($srcd=~/^\Q$docroot\E\/res/) { 1744: print $logfile "\nPANIC: Target dir is ".$srcd; 1745: $r->print( 1746: "<span class=\"LC_error\">".&mt('Invalid target directory, FAIL')."</span>"); 1747: return 0; 1748: } 1749: opendir(DIR,$srcd); 1750: while ($filename=readdir(DIR)) { 1751: if (-l $srcd.'/'.$filename) { 1752: unlink($srcd.'/'.$filename); 1753: unlink($srcd.'/'.$filename.'.meta'); 1754: } else { 1755: if ($filename=~/^\Q$srcf\E\.(\d+)\.\Q$srct\E$/) { 1756: $maxversion=($1>$maxversion)?$1:$maxversion; 1757: } 1758: } 1759: } 1760: closedir(DIR); 1761: $maxversion++; 1762: $r->print('<p>'.&mt('Creating old version [_1]',$maxversion).'</p>'); 1763: print $logfile "\nCreating old version ".$maxversion."\n"; 1764: 1765: my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct; 1766: 1767: if (copy($target,$copyfile)) { 1768: print $logfile "Copied old target to ".$copyfile."\n"; 1769: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied old target file'))); 1770: } else { 1771: print $logfile "Unable to write ".$copyfile.':'.$!."\n"; 1772: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Failed to copy old target').", $!",1)); 1773: return 0; 1774: } 1775: 1776: # --------------------------------------------------------------- Copy Metadata 1777: 1778: $copyfile=$copyfile.'.meta'; 1779: 1780: if (copy($target.'.meta',$copyfile)) { 1781: print $logfile "Copied old target metadata to ".$copyfile."\n"; 1782: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied old metadata'))); 1783: } else { 1784: print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; 1785: if (-e $target.'.meta') { 1786: $r->print(&Apache::lonhtmlcommon::confirm_success( 1787: &mt('Failed to write old metadata copy').", $!",1)); 1788: return 0; 1789: } 1790: } 1791: 1792: 1793: } else { 1794: $r->print('<p>'.&mt('Initial version').'</p>'); 1795: print $logfile "\nInitial version"; 1796: } 1797: 1798: # ---------------------------------------------------------------- Write Source 1799: my $copyfile=$target; 1800: 1801: my @parts=split(/\//,$copyfile); 1802: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 1803: 1804: my $count; 1805: for ($count=5;$count<$#parts;$count++) { 1806: $path.="/$parts[$count]"; 1807: if ((-e $path)!=1) { 1808: print $logfile "\nCreating directory ".$path; 1809: mkdir($path,0777); 1810: $r->print('<p>' 1811: .&mt('Created directory [_1]' 1812: ,'<span class="LC_filename">'.$parts[$count].'</span>') 1813: .'</p>' 1814: ); 1815: } 1816: } 1817: 1818: if (copy($source,$copyfile)) { 1819: print $logfile "\nCopied original source to ".$copyfile."\n"; 1820: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied source file'))); 1821: } else { 1822: print $logfile "\nUnable to write ".$copyfile.':'.$!."\n"; 1823: $r->print(&Apache::lonhtmlcommon::confirm_success( 1824: &mt('Failed to copy source').", $!",1)); 1825: return 0; 1826: } 1827: 1828: # ---------------------------------------------- Delete local tmp-preview files 1829: unlink($copyfile.'.tmp'); 1830: # --------------------------------------------------------------- Copy Metadata 1831: 1832: $copyfile=$copyfile.'.meta'; 1833: 1834: if (copy($source.'.meta',$copyfile)) { 1835: print $logfile "\nCopied original metadata to ".$copyfile."\n"; 1836: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied metadata'))); 1837: } else { 1838: print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n"; 1839: $r->print(&Apache::lonhtmlcommon::confirm_success( 1840: &mt('Failed to write metadata copy').", $!",1)); 1841: return 0; 1842: } 1843: $r->rflush; 1844: 1845: # ------------------------------------------------------------- Trigger updates 1846: push(@{$modified_urls},[$target,$source]); 1847: unless ($registered_cleanup) { 1848: my $handlers = $r->get_handlers('PerlCleanupHandler'); 1849: $r->set_handlers('PerlCleanupHandler' => [\&notify,@{$handlers}]); 1850: $registered_cleanup=1; 1851: } 1852: 1853: # ---------------------------------------------------------- Clear local caches 1854: my $thisdistarget=$target; 1855: $thisdistarget=~s/^\Q$docroot\E//; 1856: &Apache::lonnet::devalidate_cache_new('resversion',$target); 1857: &Apache::lonnet::devalidate_cache_new('meta', 1858: &Apache::lonnet::declutter($thisdistarget)); 1859: 1860: # ------------------------------------------------------------- Everything done 1861: $logfile->close(); 1862: $r->print('<p class="LC_success">'.&mt('Done').'</p>'); 1863: 1864: # ------------------------------------------------ Provide link to new resource 1865: unless ($batch) { 1866: 1867: my $thissrc=&Apache::loncfile::url($source); 1868: my $thissrcdir=$thissrc; 1869: $thissrcdir=~s/\/[^\/]+$/\//; 1870: 1871: $r->print( 1872: &Apache::lonhtmlcommon::actionbox([ 1873: '<a href="'.$thisdistarget.'">'. 1874: &mt('View Published Version'). 1875: '</a>', 1876: '<a href="'.$thissrc.'">'. 1877: &mt('Back to Source'). 1878: '</a>', 1879: '<a href="'.$thissrcdir.'">'. 1880: &mt('Back to Source Directory'). 1881: '</a>']) 1882: ); 1883: } 1884: return 1; 1885: } 1886: 1887: # =============================================================== Notifications 1888: sub notify { 1889: # --------------------------------------------------- Send update notifications 1890: foreach my $targetsource (@{$modified_urls}){ 1891: my ($target,$source)=@{$targetsource}; 1892: my $logfile=Apache::File->new('>>'.$source.'.log'); 1893: print $logfile "\nCleanup phase: Notifications\n"; 1894: my @subscribed=&get_subscribed_hosts($target); 1895: foreach my $subhost (@subscribed) { 1896: print $logfile "\nNotifying host ".$subhost.':'; 1897: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); 1898: print $logfile $reply; 1899: } 1900: # ---------------------------------------- Send update notifications, meta only 1901: my @subscribedmeta=&get_subscribed_hosts("$target.meta"); 1902: foreach my $subhost (@subscribedmeta) { 1903: print $logfile "\nNotifying host for metadata only ".$subhost.':'; 1904: my $reply=&Apache::lonnet::critical('update:'.$target.'.meta', 1905: $subhost); 1906: print $logfile $reply; 1907: } 1908: # --------------------------------------------------- Notify subscribed courses 1909: my %courses=&coursedependencies($target); 1910: my $now=time; 1911: foreach (keys %courses) { 1912: print $logfile "\nNotifying course ".$_.':'; 1913: my ($cdom,$cname)=split(/\_/,$_); 1914: my $reply=&Apache::lonnet::cput 1915: ('versionupdate',{$target => $now},$cdom,$cname); 1916: print $logfile $reply; 1917: } 1918: print $logfile "\n============ Done ============\n"; 1919: $logfile->close(); 1920: } 1921: if ($lock) { &Apache::lonnet::remove_lock($lock); } 1922: return OK; 1923: } 1924: 1925: ######################################### 1926: 1927: sub batchpublish { 1928: my ($r,$srcfile,$targetfile)=@_; 1929: #publication pollutes %env with form.* values 1930: my %oldenv=%env; 1931: $srcfile=~s/\/+/\//g; 1932: $targetfile=~s/\/+/\//g; 1933: $srcfile=~s/\/+/\//g; 1934: 1935: my $docroot=$r->dir_config('lonDocRoot'); 1936: my $thisdistarget=$targetfile; 1937: $thisdistarget=~s/^\Q$docroot\E//; 1938: 1939: 1940: %metadatafields=(); 1941: %metadatakeys=(); 1942: $srcfile=~/\.(\w+)$/; 1943: my $thistype=$1; 1944: 1945: 1946: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); 1947: 1948: $r->print('<h2>' 1949: .&mt('Publishing [_1]',&Apache::loncfile::display($srcfile)) 1950: .'</h2>' 1951: ); 1952: 1953: # phase one takes 1954: # my ($source,$target,$style,$batch)=@_; 1955: my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1); 1956: $r->print('<p>'.$outstring.'</p>'); 1957: # phase two takes 1958: # my ($source,$target,$style,$distarget,batch)=@_; 1959: # $env{'form.allmeta'},$env{'form.title'},$env{'form.author'},... 1960: if (!$error) { 1961: $r->print('<p>'); 1962: &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1); 1963: $r->print('</p>'); 1964: } 1965: %env=%oldenv; 1966: return ''; 1967: } 1968: 1969: ######################################### 1970: 1971: sub publishdirectory { 1972: my ($r,$fn,$thisdisfn)=@_; 1973: $fn=~s/\/+/\//g; 1974: $thisdisfn=~s/\/+/\//g; 1975: my $thisdisresdir=$thisdisfn; 1976: $thisdisresdir=~s/^\/priv\//\/res\//; 1977: my $resdir = $r->dir_config('lonDocRoot').$thisdisresdir; 1978: $r->print('<form name="pubdirpref" method="post" action="">' 1979: .&Apache::lonhtmlcommon::start_pick_box() 1980: .&Apache::lonhtmlcommon::row_title(&mt('Directory')) 1981: .'<span class="LC_filename">'.$thisdisfn.'</span>' 1982: .&Apache::lonhtmlcommon::row_closure() 1983: .&Apache::lonhtmlcommon::row_title(&mt('Target')) 1984: .'<span class="LC_filename">'.$thisdisresdir.'</span>' 1985: ); 1986: 1987: my $dirptr=16384; # Mask indicating a directory in stat.cmode. 1988: unless ($env{'form.phase'} eq 'two') { 1989: # ask user what they want 1990: $r->print(&Apache::lonhtmlcommon::row_closure() 1991: .&Apache::lonhtmlcommon::row_title(&mt('Options')) 1992: ); 1993: $r->print(&hiddenfield('phase','two'). 1994: &hiddenfield('filename',$env{'form.filename'}). 1995: &checkbox('pubrec','include subdirectories'). 1996: &checkbox('forcerepub','force republication of previously published files'). 1997: &checkbox('obsolete','make file(s) obsolete'). 1998: &checkbox('forceoverride','force directory level metadata over existing') 1999: ); 2000: $r->print(&Apache::lonhtmlcommon::row_closure(1) 2001: .&Apache::lonhtmlcommon::end_pick_box() 2002: .'<br /><input type="submit" value="'.&mt('Publish Directory').'" /></form>' 2003: ); 2004: $lock=0; 2005: } else { 2006: $r->print(&Apache::lonhtmlcommon::row_closure(1) 2007: .&Apache::lonhtmlcommon::end_pick_box() 2008: ); 2009: unless ($lock) { $lock=&Apache::lonnet::set_lock(&mt('Publishing [_1]',$fn)); } 2010: # actually publish things 2011: opendir(DIR,$fn); 2012: my @files=sort(readdir(DIR)); 2013: foreach my $filename (@files) { 2014: my ($cdev,$cino,$cmode,$cnlink, 2015: $cuid,$cgid,$crdev,$csize, 2016: $catime,$cmtime,$cctime, 2017: $cblksize,$cblocks)=stat($fn.'/'.$filename); 2018: 2019: my $extension=''; 2020: if ($filename=~/\.(\w+)$/) { $extension=$1; } 2021: if ($cmode&$dirptr) { 2022: if (($filename!~/^\./) && ($env{'form.pubrec'})) { 2023: &publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename); 2024: } 2025: } elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') && 2026: ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) { 2027: # find out publication status and/or exiting metadata 2028: my $publishthis=0; 2029: if (-e $resdir.'/'.$filename) { 2030: my ($rdev,$rino,$rmode,$rnlink, 2031: $ruid,$rgid,$rrdev,$rsize, 2032: $ratime,$rmtime,$rctime, 2033: $rblksize,$rblocks)=stat($resdir.'/'.$filename); 2034: if (($rmtime<$cmtime) || ($env{'form.forcerepub'})) { 2035: # previously published, modified now 2036: $publishthis=1; 2037: } 2038: my $meta_cmtime = (stat($fn.'/'.$filename.'.meta'))[9]; 2039: my $meta_rmtime = (stat($resdir.'/'.$filename.'.meta'))[9]; 2040: if ( $meta_rmtime<$meta_cmtime ) { 2041: $publishthis=1; 2042: } 2043: } else { 2044: # never published 2045: $publishthis=1; 2046: } 2047: 2048: if ($publishthis) { 2049: &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename); 2050: } else { 2051: $r->print('<br />'.&mt('Skipping').' '.$filename.'<br />'); 2052: } 2053: $r->rflush(); 2054: } 2055: } 2056: closedir(DIR); 2057: } 2058: } 2059: 2060: ######################################### 2061: # publish a default.meta file 2062: 2063: sub defaultmetapublish { 2064: my ($r,$fn,$cuname,$cudom)=@_; 2065: unless (-e $fn) { 2066: return HTTP_NOT_FOUND; 2067: } 2068: my $target=$fn; 2069: $target=~s/^\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/priv\//\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/res\//; 2070: 2071: 2072: &Apache::loncommon::content_type($r,'text/html'); 2073: $r->send_http_header; 2074: 2075: $r->print(&Apache::loncommon::start_page('Metadata Publication')); 2076: 2077: # ---------------------------------------------------------------- Write Source 2078: my $copyfile=$target; 2079: 2080: my @parts=split(/\//,$copyfile); 2081: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 2082: 2083: my $count; 2084: for ($count=5;$count<$#parts;$count++) { 2085: $path.="/$parts[$count]"; 2086: if ((-e $path)!=1) { 2087: mkdir($path,0777); 2088: $r->print('<p>' 2089: .&mt('Created directory [_1]' 2090: ,'<span class="LC_filename">'.$parts[$count].'</span>') 2091: .'</p>' 2092: ); 2093: } 2094: } 2095: 2096: if (copy($fn,$copyfile)) { 2097: $r->print('<p>'.&mt('Copied source file').'</p>'); 2098: } else { 2099: return "<span class=\"LC_error\">". 2100: &mt('Failed to copy source').", $!, ".&mt('FAIL')."</span>"; 2101: } 2102: 2103: # --------------------------------------------------- Send update notifications 2104: 2105: my @subscribed=&get_subscribed_hosts($target); 2106: foreach my $subhost (@subscribed) { 2107: $r->print('<p>'.&mt('Notifying host').' '.$subhost.':');$r->rflush; 2108: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); 2109: $r->print($reply.'</p><br />');$r->rflush; 2110: } 2111: # ------------------------------------------------------------------- Link back 2112: $r->print("<a href='".&Apache::loncfile::display($fn)."'>".&mt('Back to Metadata').'</a>'); 2113: $r->print(&Apache::loncommon::end_page()); 2114: return OK; 2115: } 2116: ######################################### 2117: 2118: =pod 2119: 2120: =item B<handler> 2121: 2122: A basic outline of the handler subroutine follows. 2123: 2124: =over 4 2125: 2126: =item * 2127: 2128: Get query string for limited number of parameters. 2129: 2130: =item * 2131: 2132: Check filename. 2133: 2134: =item * 2135: 2136: File is there and owned, init lookup tables. 2137: 2138: =item * 2139: 2140: Start page output. 2141: 2142: =item * 2143: 2144: Evaluate individual file, and then output information. 2145: 2146: =item * 2147: 2148: Publishing from $thisfn to $thistarget with $thisembstyle. 2149: 2150: =back 2151: 2152: =cut 2153: 2154: ######################################### 2155: ######################################### 2156: sub handler { 2157: my $r=shift; 2158: 2159: if ($r->header_only) { 2160: &Apache::loncommon::content_type($r,'text/html'); 2161: $r->send_http_header; 2162: return OK; 2163: } 2164: 2165: # Get query string for limited number of parameters 2166: 2167: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, 2168: ['filename']); 2169: 2170: # -------------------------------------- Flag and buffer for registered cleanup 2171: $registered_cleanup=0; 2172: @{$modified_urls}=(); 2173: # -------------------------------------------------------------- Check filename 2174: 2175: my $fn=&unescape($env{'form.filename'}); 2176: ($cuname,$cudom)=&Apache::lonnet::constructaccess($fn); 2177: # ----------------------------------------------------- Do we have permissions? 2178: unless (($cuname) && ($cudom)) { 2179: $r->log_reason($env{'user.name'}.' at '.$env{'user.domain'}. 2180: ' trying to publish file '.$env{'form.filename'}. 2181: ' - not authorized', 2182: $r->filename); 2183: return HTTP_NOT_ACCEPTABLE; 2184: } 2185: # ----------------------------------------------------------------- Get docroot 2186: $docroot=$r->dir_config('lonDocRoot'); 2187: 2188: 2189: # special publication: default.meta file 2190: if ($fn=~/\/default.meta$/) { 2191: return &defaultmetapublish($r,$fn,$cuname,$cudom); 2192: } 2193: $fn=~s/\.meta$//; 2194: 2195: # sanity test on the filename 2196: 2197: unless ($fn) { 2198: $r->log_reason($cuname.' at '.$cudom. 2199: ' trying to publish empty filename', $r->filename); 2200: return HTTP_NOT_FOUND; 2201: } 2202: 2203: unless (-e $docroot.$fn) { 2204: $r->log_reason($cuname.' at '.$cudom. 2205: ' trying to publish non-existing file '. 2206: $env{'form.filename'}.' ('.$fn.')', 2207: $r->filename); 2208: return HTTP_NOT_FOUND; 2209: } 2210: 2211: # -------------------------------- File is there and owned, init lookup tables. 2212: 2213: %addid=(); 2214: 2215: { 2216: my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab'); 2217: while (<$fh>=~/(\w+)\s+(\w+)/) { 2218: $addid{$1}=$2; 2219: } 2220: } 2221: 2222: %nokey=(); 2223: 2224: { 2225: my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); 2226: while (<$fh>) { 2227: my $word=$_; 2228: chomp($word); 2229: $nokey{$word}=1; 2230: } 2231: } 2232: 2233: # ---------------------------------------------------------- Start page output. 2234: 2235: &Apache::loncommon::content_type($r,'text/html'); 2236: $r->send_http_header; 2237: 2238: # Breadcrumbs 2239: &Apache::lonhtmlcommon::clear_breadcrumbs(); 2240: &Apache::lonhtmlcommon::add_breadcrumb({ 2241: 'text' => 'Authoring Space', 2242: 'href' => &Apache::loncommon::authorspace($fn), 2243: }); 2244: &Apache::lonhtmlcommon::add_breadcrumb({ 2245: 'text' => 'Resource Publication', 2246: 'href' => '', 2247: }); 2248: 2249: my $js='<script type="text/javascript">'. 2250: &Apache::loncommon::browser_and_searcher_javascript(). 2251: '</script>'; 2252: $r->print(&Apache::loncommon::start_page('Resource Publication',$js) 2253: .&Apache::lonhtmlcommon::breadcrumbs() 2254: .&Apache::loncommon::head_subbox( 2255: &Apache::loncommon::CSTR_pageheader($docroot.$fn)) 2256: ); 2257: 2258: my $thisdisfn=&HTML::Entities::encode($fn,'<>&"'); 2259: my $thistarget=$fn; 2260: $thistarget=~s/^\/priv\//\/res\//; 2261: my $thisdistarget=&HTML::Entities::encode($thistarget,'<>&"'); 2262: 2263: if ($fn=~/\/$/) { 2264: # -------------------------------------------------------- This is a directory 2265: &publishdirectory($r,$docroot.$fn,$thisdisfn); 2266: $r->print( 2267: '<br /><br />'. 2268: &Apache::lonhtmlcommon::actionbox([ 2269: '<a href="'.$thisdisfn.'">'.&mt('Return to Directory').'</a>'])); 2270: } else { 2271: # ---------------------- Evaluate individual file, and then output information. 2272: $fn=~/\.(\w+)$/; 2273: my $thistype=$1; 2274: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); 2275: if ($thistype eq 'page') { $thisembstyle = 'rat'; } 2276: 2277: $r->print('<h2>' 2278: .&mt('Publishing [_1]' 2279: ,'<span class="LC_filename">'.$thisdisfn.'</span>') 2280: .'</h2>' 2281: ); 2282: 2283: $r->print('<h3>'.&mt('Resource Details').'</h3>'); 2284: 2285: $r->print(&Apache::lonhtmlcommon::start_pick_box()); 2286: 2287: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Type')) 2288: .&Apache::loncommon::filedescription($thistype) 2289: .&Apache::lonhtmlcommon::row_closure() 2290: ); 2291: 2292: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Link to Resource')) 2293: .'<tt>' 2294: ); 2295: $r->print(<<ENDCAPTION); 2296: <a href='javascript:void(window.open("$thisdisfn","cat","height=300,width=500,scrollbars=1,resizable=1,menubar=0,location=1"))'> 2297: $thisdisfn</a> 2298: ENDCAPTION 2299: $r->print('</tt>' 2300: .&Apache::lonhtmlcommon::row_closure() 2301: ); 2302: 2303: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Target')) 2304: .'<tt>'.$thisdistarget.'</tt>' 2305: ); 2306: if (($cuname ne $env{'user.name'})||($cudom ne $env{'user.domain'})) { 2307: $r->print(&Apache::lonhtmlcommon::row_closure() 2308: .&Apache::lonhtmlcommon::row_title(&mt('Co-Author')) 2309: .'<span class="LC_warning">' 2310: .&Apache::loncommon::plainname($cuname,$cudom) .' ('.$cuname.':'.$cudom.')' 2311: .'</span>' 2312: ); 2313: } 2314: 2315: if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { 2316: $r->print(&Apache::lonhtmlcommon::row_closure() 2317: .&Apache::lonhtmlcommon::row_title(&mt('Diffs'))); 2318: $r->print(<<ENDDIFF); 2319: <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"))'> 2320: ENDDIFF 2321: $r->print(&mt('Diffs with Current Version').'</a>'); 2322: } 2323: 2324: $r->print(&Apache::lonhtmlcommon::row_closure(1) 2325: .&Apache::lonhtmlcommon::end_pick_box() 2326: ); 2327: 2328: # ---------------------- Publishing from $fn to $thistarget with $thisembstyle. 2329: 2330: unless ($env{'form.phase'} eq 'two') { 2331: # ---------------------------------------------------------- Parse for problems 2332: my ($warningcount,$errorcount); 2333: if ($thisembstyle eq 'ssi') { 2334: ($warningcount,$errorcount)=&checkonthis($r,$fn); 2335: } 2336: unless ($errorcount) { 2337: my ($outstring,$error)= 2338: &publish($docroot.$fn,$docroot.$thistarget,$thisembstyle); 2339: $r->print($outstring); 2340: } else { 2341: $r->print('<h3 class="LC_error">'. 2342: &mt('The document contains errors and cannot be published.'). 2343: '</h3>'); 2344: } 2345: } else { 2346: &phasetwo($r,$docroot.$fn,$docroot.$thistarget,$thisembstyle,$thisdistarget); 2347: } 2348: } 2349: $r->print(&Apache::loncommon::end_page()); 2350: 2351: return OK; 2352: } 2353: 2354: 1; 2355: __END__ 2356: 2357: =pod 2358: 2359: =back 2360: 2361: =cut 2362: