loncom/publisher/lonpublisher.pm - view

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

- Additional arg for set_allow() - $type, which is the attribute (in the tag)
  which requires an allow to be set.
- For $type = src or href remove any query string appended to the url before
  setting the value of the src in the allow tag.

1: # The LearningOnline Network with CAPA 2: # Publication Handler 3: # 4: # $Id: lonpublisher.pm,v 1.290 2014/07/27 11:14:36 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: $parms{$key}=&set_allow(\%allow,$logfile, 730: $target,$tag, 731: $parms{$key},$type); 732: } 733: } 734: } 735: } 736: # probably a <randomlabel> image type <label> 737: # or a <image> tag inside <imageresponse> 738: if (($lctag eq 'label' && defined($parms{'description'})) 739: || 740: ($lctag eq 'image')) { 741: my $next_token=$parser[-1]->get_token(); 742: if ($next_token->[0] eq 'T') { 743: $next_token->[1] =~ s/[\n\r\f]+//g; 744: $next_token->[1]=&set_allow(\%allow,$logfile, 745: $target,$tag, 746: $next_token->[1]); 747: } 748: $parser[-1]->unget_token($next_token); 749: } 750: if ($lctag eq 'applet') { 751: my $codebase=''; 752: my $havecodebase=0; 753: foreach my $key (keys(%parms)) { 754: if (lc($key) eq 'codebase') { 755: $codebase=$parms{$key}; 756: $havecodebase=1; 757: } 758: } 759: if ($havecodebase) { 760: my $oldcodebase=$codebase; 761: unless ($oldcodebase=~/\/$/) { 762: $oldcodebase.='/'; 763: } 764: $codebase=&urlfixup($oldcodebase,$target); 765: $codebase=~s/\/$//; 766: if ($codebase ne $oldcodebase) { 767: $parms{'codebase'}=$codebase; 768: print $logfile 'URL codebase: '.$tag.':'. 769: $oldcodebase.' - '. 770: $codebase."\n"; 771: } 772: $allow{&absoluteurl($codebase,$target).'/*'}=1; 773: } else { 774: foreach my $key (keys(%parms)) { 775: if ($key =~ /(archive|code|object)/i) { 776: my $oldurl=$parms{$key}; 777: my $newurl=&urlfixup($oldurl,$target); 778: $newurl=~s/\/[^\/]+$/\/\*/; 779: print $logfile 'Allow: applet '.lc($key).':'. 780: $oldurl.' allows '.$newurl."\n"; 781: $allow{&absoluteurl($newurl,$target)}=1; 782: } 783: } 784: } 785: } 786: my $newparmstring=''; 787: my $endtag=''; 788: foreach (keys %parms) { 789: if ($_ eq '/') { 790: $endtag=' /'; 791: } else { 792: my $quote=($parms{$_}=~/\"/?"'":'"'); 793: $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; 794: } 795: } 796: if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } 797: $outstring.='<'.$tag.$newparmstring.$endtag.'>'; 798: if ($lctag eq 'm' || $lctag eq 'answer' || $lctag eq 'display' || 799: $lctag eq 'tex') { 800: $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser); 801: } elsif ($lctag eq 'script') { 802: if ($parms{'type'} eq 'loncapa/perl') { 803: $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser); 804: } else { 805: my $script = &get_all_text_unbalanced('/'.$lctag,\@parser); 806: if ($script =~ m{\.set\w+(Src|Swf)$["']}i) { 807: my @srcs = split(/\.set/i,$script); 808: if (scalar(@srcs) > 1) { 809: foreach my $item (@srcs) { 810: if ($item =~ m{^(FlashPlayerSwf|MediaSrc|XMPSrc|ConfigurationSrc|PosterImageSrc)\((['"])(?:(?!\2).)+\2$}is) { 811: my $srctype = $1; 812: my $quote = $2; 813: my ($url) = ($item =~ m{^\Q$srctype($quote\E([^$quote]+)\Q$quote)\E}); 814: $url = &urlfixup($url); 815: unless ($url=~m{^(?:http|https|ftp)://}) { 816: $allow{&absoluteurl($url,$target)}=1; 817: if ($srctype eq 'ConfigurationSrc') { 818: if ($url =~ m{^(.+/)configuration_express\.xml$}) { 819: # 820: # Camtasia 8.1: express_show/spritesheet.png needed, and included in zip archive. 821: # Not referenced directly in <main>.html or <main>_player.html files, 822: # so add this file to %allow (where <main> is name user gave to file/archive). 823: # 824: my $spritesheet = $1.'express_show/spritesheet.png'; 825: $allow{&absoluteurl($spritesheet,$target)}=1; 826: } 827: } elsif ($srctype eq 'PosterImageSrc') { 828: if ($url =~ m{^(.+)_First_Frame\.png$}) { 829: my $prefix = $1; 830: # 831: # Camtasia 8.1: <main>_Thumbnails.png needed, and included in zip archive. 832: # Not referenced directly in <main>.html or <main>_player.html files, 833: # so add this file to %allow (where <main> is name user gave to file/archive). 834: # 835: my $thumbnail = $prefix.'_Thumbnails.png'; 836: $allow{&absoluteurl($thumbnail,$target)}=1; 837: } 838: } 839: } 840: } 841: } 842: } 843: } 844: $outstring .= $script; 845: } 846: } 847: } elsif ($token->[0] eq 'E') { 848: if ($token->[2]) { 849: unless ($token->[1] eq 'allow') { 850: $outstring.='</'.$token->[1].'>'; 851: } 852: } 853: if ((($token->[1] eq 'part') || ($token->[1] eq 'problem')) 854: && (!$responsecounter)) { 855: my $outstring='<span class="LC_error">'.&mt('Found [_1] without responses. This resource cannot be published.',$token->[1]).'</span>'; 856: return ($outstring,1); 857: } 858: } else { 859: $outstring.=$token->[1]; 860: } 861: } 862: pop(@parser); 863: } 864: 865: if ($needsfixup) { 866: print $logfile "End of ID and/or index fixup\n". 867: "Max ID : $maxid (min 10)\n". 868: "Max Index: $maxindex (min 10)\n"; 869: } else { 870: print $logfile "Does not need ID and/or index fixup\n"; 871: } 872: 873: return ($outstring,0,%allow); 874: } 875: 876: ######################################### 877: ######################################### 878: 879: =pod 880: 881: =item B<store_metadata> 882: 883: Store the metadata in the metadata table in the loncapa database. 884: Uses lonmysql to access the database. 885: 886: Inputs: \%metadata 887: 888: Returns: (error,status). error is undef on success, status is undef on error. 889: 890: =cut 891: 892: ######################################### 893: ######################################### 894: sub store_metadata { 895: my %metadata = @_; 896: my $error; 897: # Determine if the table exists 898: my $status = &Apache::lonmysql::check_table('metadata'); 899: if (! defined($status)) { 900: $error='<span class="LC_error">' 901: .&mt('WARNING: Cannot connect to database!') 902: .'</span>'; 903: &Apache::lonnet::logthis($error); 904: return ($error,undef); 905: } 906: if ($status == 0) { 907: # It would be nice to actually create the table.... 908: $error ='<span class="LC_error">' 909: .&mt('WARNING: The metadata table does not exist in the LON-CAPA database!') 910: .'</span>'; 911: &Apache::lonnet::logthis($error); 912: return ($error,undef); 913: } 914: my $dbh = &Apache::lonmysql::get_dbh(); 915: if (($metadata{'obsolete'}) || ($metadata{'copyright'} eq 'priv')) { 916: # remove this entry 917: my $delitem = 'url = '.$dbh->quote($metadata{'url'}); 918: $status = &LONCAPA::lonmetadata::delete_metadata($dbh,undef,$delitem); 919: 920: } else { 921: $status = &LONCAPA::lonmetadata::update_metadata($dbh,undef,undef, 922: \%metadata); 923: } 924: if (defined($status) && $status ne '') { 925: $error='<span class="LC_error">' 926: .&mt('Error occurred saving new values in metadata table in LON-CAPA database!') 927: .'</span>'; 928: &Apache::lonnet::logthis($error); 929: &Apache::lonnet::logthis($status); 930: return ($error,undef); 931: } 932: return (undef,'success'); 933: } 934: 935: 936: # ========================================== Parse file for errors and warnings 937: 938: sub checkonthis { 939: my ($r,$source)=@_; 940: my $uri=&Apache::lonnet::hreflocation($source); 941: $uri=~s/\/$//; 942: my $result=&Apache::lonnet::ssi_body($uri, 943: ('grade_target'=>'web', 944: 'return_only_error_and_warning_counts' => 1)); 945: my ($errorcount,$warningcount)=split(':',$result); 946: if (($errorcount) || ($warningcount)) { 947: $r->print('<h3>'.&mt('Warnings and Errors').'</h3>'); 948: $r->print('<tt>'.$uri.'</tt>:'); 949: $r->print('<ul>'); 950: if ($warningcount) { 951: $r->print('<li><div class="LC_warning">' 952: .&mt('[quant,_1,warning]',$warningcount) 953: .'</div></li>'); 954: } 955: if ($errorcount) { 956: $r->print('<li><div class="LC_error">' 957: .&mt('[quant,_1,error]',$errorcount) 958: .' <img src="/adm/lonMisc/bomb.gif" />' 959: .'</div></li>'); 960: } 961: $r->print('</ul>'); 962: } else { 963: #$r->print('<font color="green">'.&mt('ok').'</font>'); 964: } 965: $r->rflush(); 966: return ($warningcount,$errorcount); 967: } 968: 969: # ============================================== Parse file itself for metadata 970: # 971: # parses a file with target meta, sets global %metadatafields %metadatakeys 972: 973: sub parseformeta { 974: my ($source,$style)=@_; 975: my $allmeta=''; 976: if (($style eq 'ssi') || ($style eq 'prv')) { 977: my $dir=$source; 978: $dir=~s-/[^/]*$--; 979: my $file=$source; 980: $file=(split('/',$file))[-1]; 981: $source=&Apache::lonnet::hreflocation($dir,$file); 982: $allmeta=&Apache::lonnet::ssi_body($source,('grade_target' => 'meta')); 983: &metaeval($allmeta); 984: } 985: return $allmeta; 986: } 987: 988: ######################################### 989: ######################################### 990: 991: =pod 992: 993: =item B<publish> 994: 995: This is the workhorse function of this module. This subroutine generates 996: backup copies, performs any automatic processing (prior to publication, 997: especially for rat and ssi files), 998: 999: Returns a 2 element array, the first is the string to be shown to the 1000: user, the second is an error code, either 1 (an error occurred) or 0 1001: (no error occurred) 1002: 1003: I<Additional documentation needed.> 1004: 1005: =cut 1006: 1007: ######################################### 1008: ######################################### 1009: sub publish { 1010: 1011: my ($source,$target,$style,$batch)=@_; 1012: my $logfile; 1013: my $scrout=''; 1014: my $allmeta=''; 1015: my $content=''; 1016: my %allow=(); 1017: 1018: unless ($logfile=Apache::File->new('>>'.$source.'.log')) { 1019: return ('<span class="LC_error">'.&mt('No write permission to user directory, FAIL').'</span>',1); 1020: } 1021: print $logfile 1022: "\n\n================= Publish ".localtime()." Phase One ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n"; 1023: 1024: if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) { 1025: # ------------------------------------------------------- This needs processing 1026: 1027: # ----------------------------------------------------------------- Backup Copy 1028: my $copyfile=$source.'.save'; 1029: if (copy($source,$copyfile)) { 1030: print $logfile "Copied original file to ".$copyfile."\n"; 1031: } else { 1032: print $logfile "Unable to write backup ".$copyfile.':'.$!."\n"; 1033: return ("<span class=\"LC_error\">".&mt("Failed to write backup copy, [_1], FAIL",$1)."</span>",1); 1034: } 1035: # ------------------------------------------------------------- IDs and indices 1036: 1037: my ($outstring,$error); 1038: ($outstring,$error,%allow)=&fix_ids_and_indices($logfile,$source, 1039: $target); 1040: if ($error) { return ($outstring,$error); } 1041: # ------------------------------------------------------------ Construct Allows 1042: 1043: my $outdep=''; # Collect dependencies output data 1044: my $allowstr=''; 1045: foreach my $thisdep (sort(keys(%allow))) { 1046: if ($thisdep !~ /[^\s]/) { next; } 1047: if ($thisdep =~/\$/) { 1048: $outdep.='<div class="LC_warning">' 1049: .&mt('The resource depends on another resource with variable filename, i.e., [_1].','<tt>'.$thisdep.'</tt>').'<br />' 1050: .&mt('You likely need to explicitly allow access to all possible dependencies using the [_1]-tag.','<tt><allow></tt>') 1051: ."</div>\n"; 1052: } 1053: unless ($style eq 'rat') { 1054: $allowstr.="\n".'<allow src="'.$thisdep.'" />'; 1055: } 1056: $outdep.='<div>'; 1057: if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { 1058: $outdep.='<a href="'.$thisdep.'">'; 1059: } 1060: $outdep.='<tt>'.$thisdep.'</tt>'; 1061: if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { 1062: $outdep.='</a>'; 1063: if ( 1064: &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. 1065: $thisdep.'.meta') eq '-1') { 1066: $outdep.= ' - <span class="LC_error">'.&mt('Currently not available'). 1067: '</span>'; 1068: } else { 1069: # 1070: # Store the fact that the dependency has been used by the target file 1071: # Unfortunately, usage is erroneously named sequsage in lonmeta.pm 1072: # The translation happens in lonmetadata.pm 1073: # 1074: my %temphash=(&Apache::lonnet::declutter($target).'___'. 1075: &Apache::lonnet::declutter($thisdep).'___usage' 1076: => time); 1077: $thisdep=~m{^/res/($match_domain)/($match_username)/}; 1078: if ((defined($1)) && (defined($2))) { 1079: &Apache::lonnet::put('nohist_resevaldata',\%temphash, 1080: $1,$2); 1081: } 1082: } 1083: } 1084: $outdep.='</div><br />'; 1085: } 1086: 1087: if ($outdep) { 1088: $scrout.='<h3>'.&mt('Dependencies').'</h3>' 1089: .$outdep 1090: } 1091: $outstring=~s/\n*(\<\/[^\>]+\>[^<]*)$/$allowstr\n$1\n/s; 1092: 1093: # ------------------------------------------------------------- Write modified. 1094: 1095: { 1096: my $org; 1097: unless ($org=Apache::File->new('>'.$source)) { 1098: print $logfile "No write permit to $source\n"; 1099: return ('<span class="LC_error">'.&mt('No write permission to'). 1100: ' '.$source. 1101: ', '.&mt('FAIL').'</span>',1); 1102: } 1103: print($org $outstring); 1104: } 1105: $content=$outstring; 1106: 1107: } 1108: # -------------------------------------------- Initial step done, now metadata. 1109: 1110: # --------------------------------------- Storage for metadata keys and fields. 1111: # these are globals 1112: # 1113: %metadatafields=(); 1114: %metadatakeys=(); 1115: 1116: my %oldparmstores=(); 1117: 1118: unless ($batch) { 1119: $scrout.='<h3>'.&mt('Metadata').' ' . 1120: &Apache::loncommon::help_open_topic("Metadata_Description") 1121: . '</h3>'; 1122: } 1123: 1124: # ------------------------------------------------ First, check out environment 1125: if ((!(-e $source.'.meta')) || ($env{'form.forceoverride'})) { 1126: $metadatafields{'author'}=$env{'environment.firstname'}.' '. 1127: $env{'environment.middlename'}.' '. 1128: $env{'environment.lastname'}.' '. 1129: $env{'environment.generation'}; 1130: $metadatafields{'author'}=~s/\s+/ /g; 1131: $metadatafields{'author'}=~s/\s+$//; 1132: $metadatafields{'owner'}=$cuname.':'.$cudom; 1133: 1134: # ------------------------------------------------ Check out directory hierachy 1135: 1136: my $thisdisfn=$source; 1137: 1138: $thisdisfn=~s/^\Q$docroot\E\/priv\/\Q$cudom\E\/\Q$cuname\E\///; 1139: my @urlparts=('.',split(/\//,$thisdisfn)); 1140: $#urlparts--; 1141: 1142: my $currentpath=$docroot.'/priv/'.$cudom.'/'.$cuname.'/'; 1143: 1144: my $prefix='../'x($#urlparts); 1145: foreach my $subdir (@urlparts) { 1146: $currentpath.=$subdir.'/'; 1147: $scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix); 1148: $prefix=~s|^\.\./||; 1149: } 1150: 1151: # ----------------------------------------------------------- Parse file itself 1152: # read %metadatafields from file itself 1153: 1154: $allmeta=&parseformeta($source,$style); 1155: 1156: # ------------------- Clear out parameters and stores (there should not be any) 1157: 1158: foreach (keys %metadatafields) { 1159: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1160: delete $metadatafields{$_}; 1161: } 1162: } 1163: 1164: } else { 1165: # ---------------------- Read previous metafile, remember parameters and stores 1166: 1167: $scrout.=&metaread($logfile,$source.'.meta'); 1168: 1169: foreach (keys %metadatafields) { 1170: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1171: $oldparmstores{$_}=1; 1172: delete $metadatafields{$_}; 1173: } 1174: } 1175: # ------------------------------------------------------------- Save some stuff 1176: my %savemeta=(); 1177: foreach ('title') { 1178: if ($metadatafields{$_}) { $savemeta{$_}=$metadatafields{$_}; } 1179: } 1180: # ------------------------------------------ See if anything new in file itself 1181: 1182: $allmeta=&parseformeta($source,$style); 1183: # ----------------------------------------------------------- Restore the stuff 1184: foreach (keys %savemeta) { 1185: $metadatafields{$_}=$savemeta{$_}; 1186: } 1187: } 1188: 1189: 1190: # ---------------- Find and document discrepancies in the parameters and stores 1191: 1192: my $chparms=''; 1193: foreach (sort keys %metadatafields) { 1194: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1195: unless ($_=~/\.\w+$/) { 1196: unless ($oldparmstores{$_}) { 1197: my $disp_key = $_; 1198: $disp_key =~ tr/\0/_/; 1199: print $logfile ('New: '.$disp_key."\n"); 1200: $chparms .= $disp_key.' '; 1201: } 1202: } 1203: } 1204: } 1205: if ($chparms) { 1206: $scrout.='<p><b>'.&mt('New parameters or saved values'). 1207: ':</b> '.$chparms.'</p>'; 1208: } 1209: 1210: $chparms=''; 1211: foreach (sort keys %oldparmstores) { 1212: if (($_=~/^parameter/) || ($_=~/^stores/)) { 1213: unless (($metadatafields{$_.'.name'}) || 1214: ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { 1215: my $disp_key = $_; 1216: $disp_key =~ tr/\0/_/; 1217: print $logfile ('Obsolete: '.$disp_key."\n"); 1218: $chparms.=$disp_key.' '; 1219: } 1220: } 1221: } 1222: if ($chparms) { 1223: $scrout.='<p><b>'.&mt('Obsolete parameters or saved values').':</b> ' 1224: .$chparms.'</p>' 1225: .'<p class="LC_warning"><b>'.&mt('Warning!').'</b><br />' 1226: .&mt('If this resource is in active use, student performance data from the previous version may become inaccessible.') 1227: .'</p><hr />'; 1228: } 1229: if ($metadatafields{'copyright'} eq 'priv') { 1230: $scrout.='<p class="LC_warning"><b>'.&mt('Warning!').'</b><br />' 1231: .&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.') 1232: .'</p><hr />'; 1233: } 1234: 1235: # ------------------------------------------------------- Now have all metadata 1236: 1237: my %keywords=(); 1238: 1239: if (length($content)<500000) { 1240: my $textonly=$content; 1241: $textonly=~s/\<script[^\<]+\<\/script\>//g; 1242: $textonly=~s/\<m\>[^\<]+\<\/m\>//g; 1243: $textonly=~s/\<[^\>]*\>//g; 1244: 1245: #this is a work simplification for german authors for present 1246: $textonly=HTML::Entities::decode($textonly); #decode HTML-character 1247: $textonly=Encode::Encoder::encode('utf8', $textonly); #encode to perl internal unicode 1248: $textonly=~tr/A-ZÜÄÖ/a-züäö/; #add lowercase rule for german "Umlaute" 1249: $textonly=~s/[\$\&][a-z]\w*//g; 1250: $textonly=~s/[^a-z^ü^ä^ö^ß\s]//g; #dont delete german "Umlaute" 1251: 1252: foreach ($textonly=~m/[^\s]+/g) { #match all but whitespaces 1253: unless ($nokey{$_}) { 1254: $keywords{$_}=1; 1255: } 1256: } 1257: 1258: 1259: } 1260: 1261: foreach my $addkey (split(/[\"\'\,\;]/,$metadatafields{'keywords'})) { 1262: $addkey=~s/\s+/ /g; 1263: $addkey=~s/^\s//; 1264: $addkey=~s/\s$//; 1265: if ($addkey=~/\w/) { 1266: $keywords{$addkey}=1; 1267: } 1268: } 1269: # --------------------------------------------------- Now we also have keywords 1270: # ============================================================================= 1271: # interactive mode html goes into $intr_scrout 1272: # batch mode throws away this HTML 1273: # additionally all of the field functions have a by product of setting 1274: # $env{'from.'..} so that it can be used by the phase two handler in 1275: # batch mode 1276: 1277: my $intr_scrout.='<br />' 1278: .'<form name="pubform" action="/adm/publish" method="post">'; 1279: unless ($env{'form.makeobsolete'}) { 1280: $intr_scrout.='<p class="LC_warning">' 1281: .&mt('Searching for your resource will be based on the following metadata. Please provide as much data as possible.') 1282: .'</p>' 1283: .'<p><input type="submit" value="' 1284: .&mt('Finalize Publication') 1285: .'" /> <a href="'.&Apache::loncfile::url($source).'">'.&mt('Cancel').'</a></p>'; 1286: } 1287: $intr_scrout.=&Apache::lonhtmlcommon::start_pick_box(); 1288: $intr_scrout.= 1289: &hiddenfield('phase','two'). 1290: &hiddenfield('filename',$env{'form.filename'}). 1291: &hiddenfield('allmeta',&escape($allmeta)). 1292: &hiddenfield('dependencies',join(',',keys %allow)); 1293: unless ($env{'form.makeobsolete'}) { 1294: $intr_scrout.= 1295: &textfield('Title','title',$metadatafields{'title'}). 1296: &textfield('Author(s)','author',$metadatafields{'author'}). 1297: &textfield('Subject','subject',$metadatafields{'subject'}); 1298: # --------------------------------------------------- Scan content for keywords 1299: 1300: my $keywords_help = &Apache::loncommon::help_open_topic("Publishing_Keywords"); 1301: my $keywordout=<<"END"; 1302: <script> 1303: function checkAll(field) { 1304: for (i = 0; i < field.length; i++) 1305: field[i].checked = true ; 1306: } 1307: 1308: function uncheckAll(field) { 1309: for (i = 0; i < field.length; i++) 1310: field[i].checked = false ; 1311: } 1312: </script> 1313: END 1314: $keywordout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Keywords')) 1315: .$keywords_help 1316: .'<input type="button" value="'.&mt('check all').'" onclick="javascript:checkAll(document.pubform.keywords)" />' 1317: .'<input type="button" value="'.&mt('uncheck all').'" onclick="javascript:uncheckAll(document.pubform.keywords)" />' 1318: .'</p><br />' 1319: .&Apache::loncommon::start_data_table(); 1320: my $cols_per_row = 10; 1321: my $colcount=0; 1322: my $wordcount=0; 1323: my $numkeywords = scalar(keys(%keywords)); 1324: 1325: foreach my $word (sort(keys(%keywords))) { 1326: if ($colcount == 0) { 1327: $keywordout .= &Apache::loncommon::start_data_table_row(); 1328: } 1329: $colcount++; 1330: $wordcount++; 1331: if (($wordcount == $numkeywords) && ($colcount < $cols_per_row)) { 1332: my $colspan = 1+$cols_per_row-$colcount; 1333: $keywordout .= '<td colspan="'.$colspan.'">'; 1334: } else { 1335: $keywordout .= '<td>'; 1336: } 1337: $keywordout.='<label><input type="checkbox" name="keywords" value="'.$word.'"'; 1338: if ($metadatafields{'keywords'}) { 1339: if ($metadatafields{'keywords'}=~/\Q$word\E/) { 1340: $keywordout.=' checked="checked"'; 1341: $env{'form.keywords'}.=$word.','; 1342: } 1343: } elsif (&Apache::loncommon::keyword($word)) { 1344: $keywordout.=' checked="checked"'; 1345: $env{'form.keywords'}.=$word.','; 1346: } 1347: $keywordout.=' />'.$word.'</label></td>'; 1348: if ($colcount == $cols_per_row) { 1349: $keywordout.=&Apache::loncommon::end_data_table_row(); 1350: $colcount=0; 1351: } 1352: } 1353: if ($colcount > 0) { 1354: $keywordout .= &Apache::loncommon::end_data_table_row(); 1355: } 1356: 1357: $env{'form.keywords'}=~s/\,$//; 1358: 1359: $keywordout.=&Apache::loncommon::end_data_table_row() 1360: .&Apache::loncommon::end_data_table() 1361: .&Apache::lonhtmlcommon::row_closure(); 1362: 1363: $intr_scrout.=$keywordout; 1364: 1365: $intr_scrout.=&textfield('Additional Keywords','addkey',''); 1366: 1367: $intr_scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); 1368: 1369: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Abstract')) 1370: .'<textarea cols="80" rows="5" name="abstract">' 1371: .$metadatafields{'abstract'} 1372: .'</textarea>' 1373: .&Apache::lonhtmlcommon::row_closure(); 1374: 1375: $source=~/\.(\w+)$/; 1376: 1377: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Grade Levels')) 1378: .&mt('Lowest Grade Level:').' ' 1379: .&select_level_form($metadatafields{'lowestgradelevel'},'lowestgradelevel') 1380: # .&Apache::lonhtmlcommon::row_closure(); 1381: # $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Highest Grade Level')) 1382: .' '.&mt('Highest Grade Level:').' ' 1383: .&select_level_form($metadatafields{'highestgradelevel'},'highestgradelevel') 1384: .&Apache::lonhtmlcommon::row_closure(); 1385: 1386: $intr_scrout.=&textfield('Standards','standards',$metadatafields{'standards'}); 1387: 1388: $intr_scrout.=&hiddenfield('mime',$1); 1389: 1390: my $defaultlanguage=$metadatafields{'language'}; 1391: $defaultlanguage =~ s/\s*notset\s*//g; 1392: $defaultlanguage =~ s/^,\s*//g; 1393: $defaultlanguage =~ s/,\s*$//g; 1394: 1395: $intr_scrout.=&selectbox('Language','language', 1396: $defaultlanguage, 1397: \&Apache::loncommon::languagedescription, 1398: (&Apache::loncommon::languageids), 1399: ); 1400: 1401: unless ($metadatafields{'creationdate'}) { 1402: $metadatafields{'creationdate'}=time; 1403: } 1404: $intr_scrout.=&hiddenfield('creationdate', 1405: &Apache::lonmysql::unsqltime($metadatafields{'creationdate'})); 1406: 1407: $intr_scrout.=&hiddenfield('lastrevisiondate',time); 1408: 1409: my $pubowner_last; 1410: if ($style eq 'prv') { 1411: $pubowner_last = 1; 1412: } 1413: $intr_scrout.=&textfield('Publisher/Owner','owner', 1414: $metadatafields{'owner'},$pubowner_last); 1415: 1416: # ---------------------------------------------- Retrofix for unused copyright 1417: if ($metadatafields{'copyright'} eq 'free') { 1418: $metadatafields{'copyright'}='default'; 1419: $metadatafields{'sourceavail'}='open'; 1420: } 1421: if ($metadatafields{'copyright'} eq 'priv') { 1422: $metadatafields{'copyright'}='domain'; 1423: } 1424: # ------------------------------------------------ Dial in reasonable defaults 1425: my $defaultoption=$metadatafields{'copyright'}; 1426: unless ($defaultoption) { $defaultoption='default'; } 1427: my $defaultsourceoption=$metadatafields{'sourceavail'}; 1428: unless ($defaultsourceoption) { $defaultsourceoption='closed'; } 1429: unless ($style eq 'prv') { 1430: # -------------------------------------------------- Correct copyright for rat. 1431: if ($style eq 'rat') { 1432: # -------------------------------------- Retrofix for non-applicable copyright 1433: if ($metadatafields{'copyright'} eq 'public') { 1434: delete $metadatafields{'copyright'}; 1435: $defaultoption='default'; 1436: } 1437: $intr_scrout.=&selectbox('Copyright/Distribution','copyright', 1438: $defaultoption, 1439: \&Apache::loncommon::copyrightdescription, 1440: (grep !/^(public|priv)$/,(&Apache::loncommon::copyrightids))); 1441: } else { 1442: $intr_scrout.=&selectbox('Copyright/Distribution','copyright', 1443: $defaultoption, 1444: \&Apache::loncommon::copyrightdescription, 1445: (grep !/^priv$/,(&Apache::loncommon::copyrightids))); 1446: } 1447: my $copyright_help = 1448: &Apache::loncommon::help_open_topic('Publishing_Copyright'); 1449: my $replace=&mt('Copyright/Distribution:'); 1450: $intr_scrout =~ s/$replace/$replace.' '.$copyright_help/ge; 1451: 1452: $intr_scrout.=&text_with_browse_field('Custom Distribution File','customdistributionfile',$metadatafields{'customdistributionfile'},'rights'); 1453: $intr_scrout.=&selectbox('Source Distribution','sourceavail', 1454: $defaultsourceoption, 1455: \&Apache::loncommon::source_copyrightdescription, 1456: (&Apache::loncommon::source_copyrightids)); 1457: # $intr_scrout.=&text_with_browse_field('Source Custom Distribution File','sourcerights',$metadatafields{'sourcerights'},'rights'); 1458: my $uctitle=&mt('Obsolete'); 1459: my $obsolete_checked=($metadatafields{'obsolete'})?' checked="checked"':''; 1460: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title($uctitle) 1461: .'<input type="checkbox" name="obsolete"'.$obsolete_checked.' />' 1462: .&Apache::lonhtmlcommon::row_closure(1); 1463: $intr_scrout.=&text_with_browse_field('Suggested Replacement for Obsolete File', 1464: 'obsoletereplacement', 1465: $metadatafields{'obsoletereplacement'},'',1); 1466: } else { 1467: $intr_scrout.=&hiddenfield('copyright','private'); 1468: } 1469: } else { 1470: $intr_scrout.= 1471: &hiddenfield('title',$metadatafields{'title'}). 1472: &hiddenfield('author',$metadatafields{'author'}). 1473: &hiddenfield('subject',$metadatafields{'subject'}). 1474: &hiddenfield('keywords',$metadatafields{'keywords'}). 1475: &hiddenfield('abstract',$metadatafields{'abstract'}). 1476: &hiddenfield('notes',$metadatafields{'notes'}). 1477: &hiddenfield('mime',$metadatafields{'mime'}). 1478: &hiddenfield('creationdate',$metadatafields{'creationdate'}). 1479: &hiddenfield('lastrevisiondate',time). 1480: &hiddenfield('owner',$metadatafields{'owner'}). 1481: &hiddenfield('lowestgradelevel',$metadatafields{'lowestgradelevel'}). 1482: &hiddenfield('standards',$metadatafields{'standards'}). 1483: &hiddenfield('highestgradelevel',$metadatafields{'highestgradelevel'}). 1484: &hiddenfield('language',$metadatafields{'language'}). 1485: &hiddenfield('copyright',$metadatafields{'copyright'}). 1486: &hiddenfield('sourceavail',$metadatafields{'sourceavail'}). 1487: &hiddenfield('customdistributionfile',$metadatafields{'customdistributionfile'}). 1488: &hiddenfield('obsolete',1). 1489: &text_with_browse_field('Suggested Replacement for Obsolete File', 1490: 'obsoletereplacement', 1491: $metadatafields{'obsoletereplacement'},'',1); 1492: } 1493: if (!$batch) { 1494: $scrout.=$intr_scrout 1495: .&Apache::lonhtmlcommon::end_pick_box() 1496: .'<p><input type="submit" value="' 1497: .&mt($env{'form.makeobsolete'}?'Make Obsolete':'Finalize Publication') 1498: .'" /></p>' 1499: .'</form>'; 1500: } 1501: return($scrout,0); 1502: } 1503: 1504: ######################################### 1505: ######################################### 1506: 1507: =pod 1508: 1509: =item B<phasetwo> 1510: 1511: Render second interface showing status of publication steps. 1512: This is publication step two. 1513: 1514: Parameters: 1515: 1516: =over 4 1517: 1518: =item I<$source> 1519: 1520: =item I<$target> 1521: 1522: =item I<$style> 1523: 1524: =item I<$distarget> 1525: 1526: =back 1527: 1528: Returns: 1529: 1530: =over 4 1531: 1532: =item integer 1533: 1534: 0: fail 1535: 1: success 1536: 1537: =back 1538: 1539: =cut 1540: 1541: #'stupid emacs 1542: ######################################### 1543: ######################################### 1544: sub phasetwo { 1545: 1546: my ($r,$source,$target,$style,$distarget,$batch)=@_; 1547: $source=~s/\/+/\//g; 1548: $target=~s/\/+/\//g; 1549: # 1550: # Unless trying to get rid of something, check name validity 1551: # 1552: unless ($env{'form.obsolete'}) { 1553: if ($target=~/(\_\_\_|\&\&\&|\:\:\:)/) { 1554: $r->print('<span class="LC_error">'. 1555: &mt('Unsupported character combination [_1] in filename, FAIL.',"<tt>'.$1.'</tt>"). 1556: '</span>'); 1557: return 0; 1558: } 1559: unless ($target=~/\.(\w+)$/) { 1560: $r->print('<span class="LC_error">'.&mt('No valid extension found in filename, FAIL').'</span>'); 1561: return 0; 1562: } 1563: if ($target=~/\.(\d+)\.(\w+)$/) { 1564: $r->print('<span class="LC_error">'.&mt('Filename of resource contains internal version number. Cannot publish such resources, FAIL').'</span>'); 1565: return 0; 1566: } 1567: } 1568: 1569: # 1570: # End name check 1571: # 1572: $distarget=~s/\/+/\//g; 1573: my $logfile; 1574: unless ($logfile=Apache::File->new('>>'.$source.'.log')) { 1575: $r->print( 1576: '<span class="LC_error">'. 1577: &mt('No write permission to user directory, FAIL').'</span>'); 1578: return 0; 1579: } 1580: 1581: if ($source =~ /\.rights$/) { 1582: $r->print('<p><span class="LC_warning">'.&mt('Warning: It can take up to 1 hour for rights changes to fully propagate.').'</span></p>'); 1583: } 1584: 1585: print $logfile 1586: "\n================= Publish ".localtime()." Phase Two ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n"; 1587: 1588: %metadatafields=(); 1589: %metadatakeys=(); 1590: 1591: &metaeval(&unescape($env{'form.allmeta'})); 1592: 1593: $metadatafields{'title'}=$env{'form.title'}; 1594: $metadatafields{'author'}=$env{'form.author'}; 1595: $metadatafields{'subject'}=$env{'form.subject'}; 1596: $metadatafields{'notes'}=$env{'form.notes'}; 1597: $metadatafields{'abstract'}=$env{'form.abstract'}; 1598: $metadatafields{'mime'}=$env{'form.mime'}; 1599: $metadatafields{'language'}=$env{'form.language'}; 1600: $metadatafields{'creationdate'}=$env{'form.creationdate'}; 1601: $metadatafields{'lastrevisiondate'}=$env{'form.lastrevisiondate'}; 1602: $metadatafields{'owner'}=$env{'form.owner'}; 1603: $metadatafields{'copyright'}=$env{'form.copyright'}; 1604: $metadatafields{'standards'}=$env{'form.standards'}; 1605: $metadatafields{'lowestgradelevel'}=$env{'form.lowestgradelevel'}; 1606: $metadatafields{'highestgradelevel'}=$env{'form.highestgradelevel'}; 1607: $metadatafields{'customdistributionfile'}= 1608: $env{'form.customdistributionfile'}; 1609: $metadatafields{'sourceavail'}=$env{'form.sourceavail'}; 1610: $metadatafields{'obsolete'}=$env{'form.obsolete'}; 1611: $metadatafields{'obsoletereplacement'}= 1612: $env{'form.obsoletereplacement'}; 1613: $metadatafields{'dependencies'}=$env{'form.dependencies'}; 1614: $metadatafields{'modifyinguser'}=$env{'user.name'}.':'. 1615: $env{'user.domain'}; 1616: $metadatafields{'authorspace'}=$cuname.':'.$cudom; 1617: $metadatafields{'domain'}=$cudom; 1618: 1619: my $allkeywords=$env{'form.addkey'}; 1620: if (exists($env{'form.keywords'})) { 1621: if (ref($env{'form.keywords'})) { 1622: $allkeywords .= ','.join(',',@{$env{'form.keywords'}}); 1623: } else { 1624: $allkeywords .= ','.$env{'form.keywords'}; 1625: } 1626: } 1627: $allkeywords=~s/[\"\']//g; 1628: $allkeywords=~s/\s*[\;\,]\s*/\,/g; 1629: $allkeywords=~s/\s+/ /g; 1630: $allkeywords=~s/^[ \,]//; 1631: $allkeywords=~s/[ \,]$//; 1632: $metadatafields{'keywords'}=$allkeywords; 1633: 1634: # check if custom distribution file is specified 1635: if ($metadatafields{'copyright'} eq 'custom') { 1636: my $file=$metadatafields{'customdistributionfile'}; 1637: unless ($file=~/\.rights$/) { 1638: $r->print( 1639: '<span class="LC_error">'.&mt('No valid custom distribution rights file specified, FAIL'). 1640: '</span>'); 1641: return 0; 1642: } 1643: } 1644: { 1645: print $logfile "\nWrite metadata file for ".$source; 1646: my $mfh; 1647: unless ($mfh=Apache::File->new('>'.$source.'.meta')) { 1648: $r->print( 1649: '<span class="LC_error">'.&mt('Could not write metadata, FAIL'). 1650: '</span>'); 1651: return 0; 1652: } 1653: foreach (sort keys %metadatafields) { 1654: unless ($_=~/\./) { 1655: my $unikey=$_; 1656: $unikey=~/^([A-Za-z]+)/; 1657: my $tag=$1; 1658: $tag=~tr/A-Z/a-z/; 1659: print $mfh "\n\<$tag"; 1660: foreach (split(/\,/,$metadatakeys{$unikey})) { 1661: my $value=$metadatafields{$unikey.'.'.$_}; 1662: $value=~s/\"/\'\'/g; 1663: print $mfh ' '.$_.'="'.$value.'"'; 1664: } 1665: print $mfh '>'. 1666: &HTML::Entities::encode($metadatafields{$unikey},'<>&"') 1667: .'</'.$tag.'>'; 1668: } 1669: } 1670: $r->print('<p>'.&mt('Wrote Metadata').'</p>'); 1671: print $logfile "\nWrote metadata"; 1672: } 1673: 1674: # -------------------------------- Synchronize entry with SQL metadata database 1675: 1676: $metadatafields{'url'} = $distarget; 1677: $metadatafields{'version'} = 'current'; 1678: 1679: my ($error,$success) = &store_metadata(%metadatafields); 1680: if ($success) { 1681: $r->print('<p>'.&mt('Synchronized SQL metadata database').'</p>'); 1682: print $logfile "\nSynchronized SQL metadata database"; 1683: } else { 1684: $r->print($error); 1685: print $logfile "\n".$error; 1686: } 1687: # --------------------------------------------- Delete author resource messages 1688: my $delresult=&Apache::lonmsg::del_url_author_res_msg($target); 1689: $r->print('<p>'.&mt('Removing error messages:').' '.$delresult.'</p>'); 1690: print $logfile "\nRemoving error messages: $delresult"; 1691: # ----------------------------------------------------------- Copy old versions 1692: 1693: if (-e $target) { 1694: my $filename; 1695: my $maxversion=0; 1696: $target=~/(.*)\/([^\/]+)\.(\w+)$/; 1697: my $srcf=$2; 1698: my $srct=$3; 1699: my $srcd=$1; 1700: my $docroot = $Apache::lonnet::perlvar{'lonDocRoot'}; 1701: unless ($srcd=~/^\Q$docroot\E\/res/) { 1702: print $logfile "\nPANIC: Target dir is ".$srcd; 1703: $r->print( 1704: "<span class=\"LC_error\">".&mt('Invalid target directory, FAIL')."</span>"); 1705: return 0; 1706: } 1707: opendir(DIR,$srcd); 1708: while ($filename=readdir(DIR)) { 1709: if (-l $srcd.'/'.$filename) { 1710: unlink($srcd.'/'.$filename); 1711: unlink($srcd.'/'.$filename.'.meta'); 1712: } else { 1713: if ($filename=~/^\Q$srcf\E\.(\d+)\.\Q$srct\E$/) { 1714: $maxversion=($1>$maxversion)?$1:$maxversion; 1715: } 1716: } 1717: } 1718: closedir(DIR); 1719: $maxversion++; 1720: $r->print('<p>'.&mt('Creating old version [_1]',$maxversion).'</p>'); 1721: print $logfile "\nCreating old version ".$maxversion."\n"; 1722: 1723: my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct; 1724: 1725: if (copy($target,$copyfile)) { 1726: print $logfile "Copied old target to ".$copyfile."\n"; 1727: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied old target file'))); 1728: } else { 1729: print $logfile "Unable to write ".$copyfile.':'.$!."\n"; 1730: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Failed to copy old target').", $!",1)); 1731: return 0; 1732: } 1733: 1734: # --------------------------------------------------------------- Copy Metadata 1735: 1736: $copyfile=$copyfile.'.meta'; 1737: 1738: if (copy($target.'.meta',$copyfile)) { 1739: print $logfile "Copied old target metadata to ".$copyfile."\n"; 1740: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied old metadata'))); 1741: } else { 1742: print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; 1743: if (-e $target.'.meta') { 1744: $r->print(&Apache::lonhtmlcommon::confirm_success( 1745: &mt('Failed to write old metadata copy').", $!",1)); 1746: return 0; 1747: } 1748: } 1749: 1750: 1751: } else { 1752: $r->print('<p>'.&mt('Initial version').'</p>'); 1753: print $logfile "\nInitial version"; 1754: } 1755: 1756: # ---------------------------------------------------------------- Write Source 1757: my $copyfile=$target; 1758: 1759: my @parts=split(/\//,$copyfile); 1760: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 1761: 1762: my $count; 1763: for ($count=5;$count<$#parts;$count++) { 1764: $path.="/$parts[$count]"; 1765: if ((-e $path)!=1) { 1766: print $logfile "\nCreating directory ".$path; 1767: mkdir($path,0777); 1768: $r->print('<p>' 1769: .&mt('Created directory [_1]' 1770: ,'<span class="LC_filename">'.$parts[$count].'</span>') 1771: .'</p>' 1772: ); 1773: } 1774: } 1775: 1776: if (copy($source,$copyfile)) { 1777: print $logfile "\nCopied original source to ".$copyfile."\n"; 1778: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied source file'))); 1779: } else { 1780: print $logfile "\nUnable to write ".$copyfile.':'.$!."\n"; 1781: $r->print(&Apache::lonhtmlcommon::confirm_success( 1782: &mt('Failed to copy source').", $!",1)); 1783: return 0; 1784: } 1785: 1786: # ---------------------------------------------- Delete local tmp-preview files 1787: unlink($copyfile.'.tmp'); 1788: # --------------------------------------------------------------- Copy Metadata 1789: 1790: $copyfile=$copyfile.'.meta'; 1791: 1792: if (copy($source.'.meta',$copyfile)) { 1793: print $logfile "\nCopied original metadata to ".$copyfile."\n"; 1794: $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied metadata'))); 1795: } else { 1796: print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n"; 1797: $r->print(&Apache::lonhtmlcommon::confirm_success( 1798: &mt('Failed to write metadata copy').", $!",1)); 1799: return 0; 1800: } 1801: $r->rflush; 1802: 1803: # ------------------------------------------------------------- Trigger updates 1804: push(@{$modified_urls},[$target,$source]); 1805: unless ($registered_cleanup) { 1806: my $handlers = $r->get_handlers('PerlCleanupHandler'); 1807: $r->set_handlers('PerlCleanupHandler' => [\&notify,@{$handlers}]); 1808: $registered_cleanup=1; 1809: } 1810: 1811: # ---------------------------------------------------------- Clear local caches 1812: my $thisdistarget=$target; 1813: $thisdistarget=~s/^\Q$docroot\E//; 1814: &Apache::lonnet::devalidate_cache_new('resversion',$target); 1815: &Apache::lonnet::devalidate_cache_new('meta', 1816: &Apache::lonnet::declutter($thisdistarget)); 1817: 1818: # ------------------------------------------------------------- Everything done 1819: $logfile->close(); 1820: $r->print('<p class="LC_success">'.&mt('Done').'</p>'); 1821: 1822: # ------------------------------------------------ Provide link to new resource 1823: unless ($batch) { 1824: 1825: my $thissrc=&Apache::loncfile::url($source); 1826: my $thissrcdir=$thissrc; 1827: $thissrcdir=~s/\/[^\/]+$/\//; 1828: 1829: $r->print( 1830: &Apache::lonhtmlcommon::actionbox([ 1831: '<a href="'.$thisdistarget.'">'. 1832: &mt('View Published Version'). 1833: '</a>', 1834: '<a href="'.$thissrc.'">'. 1835: &mt('Back to Source'). 1836: '</a>', 1837: '<a href="'.$thissrcdir.'">'. 1838: &mt('Back to Source Directory'). 1839: '</a>']) 1840: ); 1841: } 1842: return 1; 1843: } 1844: 1845: # =============================================================== Notifications 1846: sub notify { 1847: # --------------------------------------------------- Send update notifications 1848: foreach my $targetsource (@{$modified_urls}){ 1849: my ($target,$source)=@{$targetsource}; 1850: my $logfile=Apache::File->new('>>'.$source.'.log'); 1851: print $logfile "\nCleanup phase: Notifications\n"; 1852: my @subscribed=&get_subscribed_hosts($target); 1853: foreach my $subhost (@subscribed) { 1854: print $logfile "\nNotifying host ".$subhost.':'; 1855: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); 1856: print $logfile $reply; 1857: } 1858: # ---------------------------------------- Send update notifications, meta only 1859: my @subscribedmeta=&get_subscribed_hosts("$target.meta"); 1860: foreach my $subhost (@subscribedmeta) { 1861: print $logfile "\nNotifying host for metadata only ".$subhost.':'; 1862: my $reply=&Apache::lonnet::critical('update:'.$target.'.meta', 1863: $subhost); 1864: print $logfile $reply; 1865: } 1866: # --------------------------------------------------- Notify subscribed courses 1867: my %courses=&coursedependencies($target); 1868: my $now=time; 1869: foreach (keys %courses) { 1870: print $logfile "\nNotifying course ".$_.':'; 1871: my ($cdom,$cname)=split(/\_/,$_); 1872: my $reply=&Apache::lonnet::cput 1873: ('versionupdate',{$target => $now},$cdom,$cname); 1874: print $logfile $reply; 1875: } 1876: print $logfile "\n============ Done ============\n"; 1877: $logfile->close(); 1878: } 1879: if ($lock) { &Apache::lonnet::remove_lock($lock); } 1880: return OK; 1881: } 1882: 1883: ######################################### 1884: 1885: sub batchpublish { 1886: my ($r,$srcfile,$targetfile)=@_; 1887: #publication pollutes %env with form.* values 1888: my %oldenv=%env; 1889: $srcfile=~s/\/+/\//g; 1890: $targetfile=~s/\/+/\//g; 1891: $srcfile=~s/\/+/\//g; 1892: 1893: my $docroot=$r->dir_config('lonDocRoot'); 1894: my $thisdistarget=$targetfile; 1895: $thisdistarget=~s/^\Q$docroot\E//; 1896: 1897: 1898: %metadatafields=(); 1899: %metadatakeys=(); 1900: $srcfile=~/\.(\w+)$/; 1901: my $thistype=$1; 1902: 1903: 1904: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); 1905: 1906: $r->print('<h2>' 1907: .&mt('Publishing [_1]',&Apache::loncfile::display($srcfile)) 1908: .'</h2>' 1909: ); 1910: 1911: # phase one takes 1912: # my ($source,$target,$style,$batch)=@_; 1913: my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1); 1914: $r->print('<p>'.$outstring.'</p>'); 1915: # phase two takes 1916: # my ($source,$target,$style,$distarget,batch)=@_; 1917: # $env{'form.allmeta'},$env{'form.title'},$env{'form.author'},... 1918: if (!$error) { 1919: $r->print('<p>'); 1920: &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1); 1921: $r->print('</p>'); 1922: } 1923: %env=%oldenv; 1924: return ''; 1925: } 1926: 1927: ######################################### 1928: 1929: sub publishdirectory { 1930: my ($r,$fn,$thisdisfn)=@_; 1931: $fn=~s/\/+/\//g; 1932: $thisdisfn=~s/\/+/\//g; 1933: my $thisdisresdir=$thisdisfn; 1934: $thisdisresdir=~s/^\/priv\//\/res\//; 1935: my $resdir = $r->dir_config('lonDocRoot').$thisdisresdir; 1936: $r->print('<form name="pubdirpref" method="post" action="">' 1937: .&Apache::lonhtmlcommon::start_pick_box() 1938: .&Apache::lonhtmlcommon::row_title(&mt('Directory')) 1939: .'<span class="LC_filename">'.$thisdisfn.'</span>' 1940: .&Apache::lonhtmlcommon::row_closure() 1941: .&Apache::lonhtmlcommon::row_title(&mt('Target')) 1942: .'<span class="LC_filename">'.$thisdisresdir.'</span>' 1943: ); 1944: 1945: my $dirptr=16384; # Mask indicating a directory in stat.cmode. 1946: unless ($env{'form.phase'} eq 'two') { 1947: # ask user what they want 1948: $r->print(&Apache::lonhtmlcommon::row_closure() 1949: .&Apache::lonhtmlcommon::row_title(&mt('Options')) 1950: ); 1951: $r->print(&hiddenfield('phase','two'). 1952: &hiddenfield('filename',$env{'form.filename'}). 1953: &checkbox('pubrec','include subdirectories'). 1954: &checkbox('forcerepub','force republication of previously published files'). 1955: &checkbox('obsolete','make file(s) obsolete'). 1956: &checkbox('forceoverride','force directory level metadata over existing') 1957: ); 1958: $r->print(&Apache::lonhtmlcommon::row_closure(1) 1959: .&Apache::lonhtmlcommon::end_pick_box() 1960: .'<br /><input type="submit" value="'.&mt('Publish Directory').'" /></form>' 1961: ); 1962: $lock=0; 1963: } else { 1964: $r->print(&Apache::lonhtmlcommon::row_closure(1) 1965: .&Apache::lonhtmlcommon::end_pick_box() 1966: ); 1967: unless ($lock) { $lock=&Apache::lonnet::set_lock(&mt('Publishing [_1]',$fn)); } 1968: # actually publish things 1969: opendir(DIR,$fn); 1970: my @files=sort(readdir(DIR)); 1971: foreach my $filename (@files) { 1972: my ($cdev,$cino,$cmode,$cnlink, 1973: $cuid,$cgid,$crdev,$csize, 1974: $catime,$cmtime,$cctime, 1975: $cblksize,$cblocks)=stat($fn.'/'.$filename); 1976: 1977: my $extension=''; 1978: if ($filename=~/\.(\w+)$/) { $extension=$1; } 1979: if ($cmode&$dirptr) { 1980: if (($filename!~/^\./) && ($env{'form.pubrec'})) { 1981: &publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename); 1982: } 1983: } elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') && 1984: ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) { 1985: # find out publication status and/or exiting metadata 1986: my $publishthis=0; 1987: if (-e $resdir.'/'.$filename) { 1988: my ($rdev,$rino,$rmode,$rnlink, 1989: $ruid,$rgid,$rrdev,$rsize, 1990: $ratime,$rmtime,$rctime, 1991: $rblksize,$rblocks)=stat($resdir.'/'.$filename); 1992: if (($rmtime<$cmtime) || ($env{'form.forcerepub'})) { 1993: # previously published, modified now 1994: $publishthis=1; 1995: } 1996: my $meta_cmtime = (stat($fn.'/'.$filename.'.meta'))[9]; 1997: my $meta_rmtime = (stat($resdir.'/'.$filename.'.meta'))[9]; 1998: if ( $meta_rmtime<$meta_cmtime ) { 1999: $publishthis=1; 2000: } 2001: } else { 2002: # never published 2003: $publishthis=1; 2004: } 2005: 2006: if ($publishthis) { 2007: &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename); 2008: } else { 2009: $r->print('<br />'.&mt('Skipping').' '.$filename.'<br />'); 2010: } 2011: $r->rflush(); 2012: } 2013: } 2014: closedir(DIR); 2015: } 2016: } 2017: 2018: ######################################### 2019: # publish a default.meta file 2020: 2021: sub defaultmetapublish { 2022: my ($r,$fn,$cuname,$cudom)=@_; 2023: unless (-e $fn) { 2024: return HTTP_NOT_FOUND; 2025: } 2026: my $target=$fn; 2027: $target=~s/^\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/priv\//\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/res\//; 2028: 2029: 2030: &Apache::loncommon::content_type($r,'text/html'); 2031: $r->send_http_header; 2032: 2033: $r->print(&Apache::loncommon::start_page('Metadata Publication')); 2034: 2035: # ---------------------------------------------------------------- Write Source 2036: my $copyfile=$target; 2037: 2038: my @parts=split(/\//,$copyfile); 2039: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 2040: 2041: my $count; 2042: for ($count=5;$count<$#parts;$count++) { 2043: $path.="/$parts[$count]"; 2044: if ((-e $path)!=1) { 2045: mkdir($path,0777); 2046: $r->print('<p>' 2047: .&mt('Created directory [_1]' 2048: ,'<span class="LC_filename">'.$parts[$count].'</span>') 2049: .'</p>' 2050: ); 2051: } 2052: } 2053: 2054: if (copy($fn,$copyfile)) { 2055: $r->print('<p>'.&mt('Copied source file').'</p>'); 2056: } else { 2057: return "<span class=\"LC_error\">". 2058: &mt('Failed to copy source').", $!, ".&mt('FAIL')."</span>"; 2059: } 2060: 2061: # --------------------------------------------------- Send update notifications 2062: 2063: my @subscribed=&get_subscribed_hosts($target); 2064: foreach my $subhost (@subscribed) { 2065: $r->print('<p>'.&mt('Notifying host').' '.$subhost.':');$r->rflush; 2066: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); 2067: $r->print($reply.'</p><br />');$r->rflush; 2068: } 2069: # ------------------------------------------------------------------- Link back 2070: $r->print("<a href='".&Apache::loncfile::display($fn)."'>".&mt('Back to Metadata').'</a>'); 2071: $r->print(&Apache::loncommon::end_page()); 2072: return OK; 2073: } 2074: ######################################### 2075: 2076: =pod 2077: 2078: =item B<handler> 2079: 2080: A basic outline of the handler subroutine follows. 2081: 2082: =over 4 2083: 2084: =item * 2085: 2086: Get query string for limited number of parameters. 2087: 2088: =item * 2089: 2090: Check filename. 2091: 2092: =item * 2093: 2094: File is there and owned, init lookup tables. 2095: 2096: =item * 2097: 2098: Start page output. 2099: 2100: =item * 2101: 2102: Evaluate individual file, and then output information. 2103: 2104: =item * 2105: 2106: Publishing from $thisfn to $thistarget with $thisembstyle. 2107: 2108: =back 2109: 2110: =cut 2111: 2112: ######################################### 2113: ######################################### 2114: sub handler { 2115: my $r=shift; 2116: 2117: if ($r->header_only) { 2118: &Apache::loncommon::content_type($r,'text/html'); 2119: $r->send_http_header; 2120: return OK; 2121: } 2122: 2123: # Get query string for limited number of parameters 2124: 2125: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, 2126: ['filename']); 2127: 2128: # -------------------------------------- Flag and buffer for registered cleanup 2129: $registered_cleanup=0; 2130: @{$modified_urls}=(); 2131: # -------------------------------------------------------------- Check filename 2132: 2133: my $fn=&unescape($env{'form.filename'}); 2134: ($cuname,$cudom)=&Apache::lonnet::constructaccess($fn); 2135: # ----------------------------------------------------- Do we have permissions? 2136: unless (($cuname) && ($cudom)) { 2137: $r->log_reason($env{'user.name'}.' at '.$env{'user.domain'}. 2138: ' trying to publish file '.$env{'form.filename'}. 2139: ' - not authorized', 2140: $r->filename); 2141: return HTTP_NOT_ACCEPTABLE; 2142: } 2143: # ----------------------------------------------------------------- Get docroot 2144: $docroot=$r->dir_config('lonDocRoot'); 2145: 2146: 2147: # special publication: default.meta file 2148: if ($fn=~/\/default.meta$/) { 2149: return &defaultmetapublish($r,$fn,$cuname,$cudom); 2150: } 2151: $fn=~s/\.meta$//; 2152: 2153: # sanity test on the filename 2154: 2155: unless ($fn) { 2156: $r->log_reason($cuname.' at '.$cudom. 2157: ' trying to publish empty filename', $r->filename); 2158: return HTTP_NOT_FOUND; 2159: } 2160: 2161: unless (-e $docroot.$fn) { 2162: $r->log_reason($cuname.' at '.$cudom. 2163: ' trying to publish non-existing file '. 2164: $env{'form.filename'}.' ('.$fn.')', 2165: $r->filename); 2166: return HTTP_NOT_FOUND; 2167: } 2168: 2169: # -------------------------------- File is there and owned, init lookup tables. 2170: 2171: %addid=(); 2172: 2173: { 2174: my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab'); 2175: while (<$fh>=~/(\w+)\s+(\w+)/) { 2176: $addid{$1}=$2; 2177: } 2178: } 2179: 2180: %nokey=(); 2181: 2182: { 2183: my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); 2184: while (<$fh>) { 2185: my $word=$_; 2186: chomp($word); 2187: $nokey{$word}=1; 2188: } 2189: } 2190: 2191: # ---------------------------------------------------------- Start page output. 2192: 2193: &Apache::loncommon::content_type($r,'text/html'); 2194: $r->send_http_header; 2195: 2196: # Breadcrumbs 2197: &Apache::lonhtmlcommon::clear_breadcrumbs(); 2198: &Apache::lonhtmlcommon::add_breadcrumb({ 2199: 'text' => 'Authoring Space', 2200: 'href' => &Apache::loncommon::authorspace($fn), 2201: }); 2202: &Apache::lonhtmlcommon::add_breadcrumb({ 2203: 'text' => 'Resource Publication', 2204: 'href' => '', 2205: }); 2206: 2207: my $js='<script type="text/javascript">'. 2208: &Apache::loncommon::browser_and_searcher_javascript(). 2209: '</script>'; 2210: $r->print(&Apache::loncommon::start_page('Resource Publication',$js) 2211: .&Apache::lonhtmlcommon::breadcrumbs() 2212: .&Apache::loncommon::head_subbox( 2213: &Apache::loncommon::CSTR_pageheader($docroot.$fn)) 2214: ); 2215: 2216: my $thisdisfn=&HTML::Entities::encode($fn,'<>&"'); 2217: my $thistarget=$fn; 2218: $thistarget=~s/^\/priv\//\/res\//; 2219: my $thisdistarget=&HTML::Entities::encode($thistarget,'<>&"'); 2220: 2221: if ($fn=~/\/$/) { 2222: # -------------------------------------------------------- This is a directory 2223: &publishdirectory($r,$docroot.$fn,$thisdisfn); 2224: $r->print( 2225: '<br /><br />'. 2226: &Apache::lonhtmlcommon::actionbox([ 2227: '<a href="'.$thisdisfn.'">'.&mt('Return to Directory').'</a>'])); 2228: } else { 2229: # ---------------------- Evaluate individual file, and then output information. 2230: $fn=~/\.(\w+)$/; 2231: my $thistype=$1; 2232: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); 2233: if ($thistype eq 'page') { $thisembstyle = 'rat'; } 2234: 2235: $r->print('<h2>' 2236: .&mt('Publishing [_1]' 2237: ,'<span class="LC_filename">'.$thisdisfn.'</span>') 2238: .'</h2>' 2239: ); 2240: 2241: $r->print('<h3>'.&mt('Resource Details').'</h3>'); 2242: 2243: $r->print(&Apache::lonhtmlcommon::start_pick_box()); 2244: 2245: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Type')) 2246: .&Apache::loncommon::filedescription($thistype) 2247: .&Apache::lonhtmlcommon::row_closure() 2248: ); 2249: 2250: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Link to Resource')) 2251: .'<tt>' 2252: ); 2253: $r->print(<<ENDCAPTION); 2254: <a href='javascript:void(window.open("$thisdisfn","cat","height=300,width=500,scrollbars=1,resizable=1,menubar=0,location=1"))'> 2255: $thisdisfn</a> 2256: ENDCAPTION 2257: $r->print('</tt>' 2258: .&Apache::lonhtmlcommon::row_closure() 2259: ); 2260: 2261: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Target')) 2262: .'<tt>'.$thisdistarget.'</tt>' 2263: ); 2264: if (($cuname ne $env{'user.name'})||($cudom ne $env{'user.domain'})) { 2265: $r->print(&Apache::lonhtmlcommon::row_closure() 2266: .&Apache::lonhtmlcommon::row_title(&mt('Co-Author')) 2267: .'<span class="LC_warning">' 2268: .&Apache::loncommon::plainname($cuname,$cudom) .' ('.$cuname.':'.$cudom.')' 2269: .'</span>' 2270: ); 2271: } 2272: 2273: if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { 2274: $r->print(&Apache::lonhtmlcommon::row_closure() 2275: .&Apache::lonhtmlcommon::row_title(&mt('Diffs'))); 2276: $r->print(<<ENDDIFF); 2277: <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"))'> 2278: ENDDIFF 2279: $r->print(&mt('Diffs with Current Version').'</a>'); 2280: } 2281: 2282: $r->print(&Apache::lonhtmlcommon::row_closure(1) 2283: .&Apache::lonhtmlcommon::end_pick_box() 2284: ); 2285: 2286: # ---------------------- Publishing from $fn to $thistarget with $thisembstyle. 2287: 2288: unless ($env{'form.phase'} eq 'two') { 2289: # ---------------------------------------------------------- Parse for problems 2290: my ($warningcount,$errorcount); 2291: if ($thisembstyle eq 'ssi') { 2292: ($warningcount,$errorcount)=&checkonthis($r,$fn); 2293: } 2294: unless ($errorcount) { 2295: my ($outstring,$error)= 2296: &publish($docroot.$fn,$docroot.$thistarget,$thisembstyle); 2297: $r->print($outstring); 2298: } else { 2299: $r->print('<h3 class="LC_error">'. 2300: &mt('The document contains errors and cannot be published.'). 2301: '</h3>'); 2302: } 2303: } else { 2304: &phasetwo($r,$docroot.$fn,$docroot.$thistarget,$thisembstyle,$thisdistarget); 2305: } 2306: } 2307: $r->print(&Apache::loncommon::end_page()); 2308: 2309: return OK; 2310: } 2311: 2312: 1; 2313: __END__ 2314: 2315: =pod 2316: 2317: =back 2318: 2319: =cut 2320: