Annotation of loncom/publisher/lonpublisher.pm, revision 1.304
1.1 www 1: # The LearningOnline Network with CAPA
2: # Publication Handler
1.54 albertel 3: #
1.304 ! raeburn 4: # $Id: lonpublisher.pm,v 1.303 2023/07/14 22:19:22 raeburn Exp $
1.54 albertel 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: #
1.65 harris41 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: ###############################################################################
1.1 www 41:
1.90 matthew 42:
43: ######################################################################
44: ######################################################################
45:
46: =pod
47:
1.94 harris41 48: =head1 NAME
1.90 matthew 49:
50: lonpublisher - LON-CAPA publishing handler
51:
1.94 harris41 52: =head1 SYNOPSIS
1.90 matthew 53:
1.94 harris41 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>
1.127 bowersj2 66:
67: =head1 OVERVIEW
68:
1.274 raeburn 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.
1.127 bowersj2 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.
1.94 harris41 86:
87: =head1 DESCRIPTION
88:
89: B<lonpublisher> takes the proper steps to add resources to the LON-CAPA
1.90 matthew 90: digital library. This includes updating the metadata table in the
91: LON-CAPA database.
92:
1.94 harris41 93: B<lonpublisher> is many things to many people.
1.90 matthew 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:
1.94 harris41 100: =head2 SUBROUTINES
101:
102: Many of the undocumented subroutines implement various magical
103: parsing shortcuts.
1.90 matthew 104:
105: =cut
106:
107: ######################################################################
108: ######################################################################
109:
110:
1.1 www 111: package Apache::lonpublisher;
112:
1.65 harris41 113: # ------------------------------------------------- modules used by this module
1.1 www 114: use strict;
115: use Apache::File;
1.13 www 116: use File::Copy;
1.2 www 117: use Apache::Constants qw(:common :http :methods);
1.76 albertel 118: use HTML::LCParser;
1.245 onken 119: use HTML::Entities;
120: use Encode::Encoder;
1.4 www 121: use Apache::lonxml;
1.24 harris41 122: use DBI;
1.192 albertel 123: use Apache::lonnet;
1.65 harris41 124: use Apache::loncommon();
1.241 raeburn 125: use Apache::lonhtmlcommon;
1.89 matthew 126: use Apache::lonmysql;
1.134 www 127: use Apache::lonlocal;
1.145 albertel 128: use Apache::loncfile;
1.166 matthew 129: use LONCAPA::lonmetadata;
1.159 www 130: use Apache::lonmsg;
1.296 raeburn 131: use vars qw(%metadatafields %metadatakeys %addid $readit);
1.215 albertel 132: use LONCAPA qw(:DEFAULT :match);
1.209 www 133:
1.12 www 134: my $docroot;
135:
1.27 www 136: my $cuname;
137: my $cudom;
138:
1.182 www 139: my $registered_cleanup;
1.183 www 140: my $modified_urls;
1.182 www 141:
1.233 www 142: my $lock;
143:
1.90 matthew 144: =pod
145:
1.287 raeburn 146: =over 4
147:
1.94 harris41 148: =item B<metaeval>
149:
150: Evaluates a string that contains metadata. This subroutine
151: stores values inside I<%metadatafields> and I<%metadatakeys>.
152: The hash key is a I<$unikey> corresponding to a unique id
153: that is descriptive of the parser location inside the XML tree.
154:
155: Parameters:
156:
157: =over 4
1.90 matthew 158:
1.94 harris41 159: =item I<$metastring>
160:
161: A string that contains metadata.
162:
163: =back
164:
165: Returns:
166:
167: nothing
1.90 matthew 168:
169: =cut
170:
171: #########################################
172: #########################################
1.144 www 173: #
174: # Modifies global %metadatafields %metadatakeys
175: #
176:
1.7 www 177: sub metaeval {
1.140 albertel 178: my ($metastring,$prefix)=@_;
1.7 www 179:
1.139 albertel 180: my $parser=HTML::LCParser->new(\$metastring);
181: my $token;
182: while ($token=$parser->get_token) {
183: if ($token->[0] eq 'S') {
184: my $entry=$token->[1];
185: my $unikey=$entry;
1.219 albertel 186: next if ($entry =~ m/^(?:parameter|stores)_/);
1.139 albertel 187: if (defined($token->[2]->{'package'})) {
1.219 albertel 188: $unikey.="\0package\0".$token->[2]->{'package'};
1.139 albertel 189: }
190: if (defined($token->[2]->{'part'})) {
1.219 albertel 191: $unikey.="\0".$token->[2]->{'part'};
1.139 albertel 192: }
193: if (defined($token->[2]->{'id'})) {
1.219 albertel 194: $unikey.="\0".$token->[2]->{'id'};
1.139 albertel 195: }
196: if (defined($token->[2]->{'name'})) {
1.219 albertel 197: $unikey.="\0".$token->[2]->{'name'};
1.139 albertel 198: }
1.294 raeburn 199: foreach my $item (@{$token->[3]}) {
200: $metadatafields{$unikey.'.'.$item}=$token->[2]->{$item};
1.139 albertel 201: if ($metadatakeys{$unikey}) {
1.294 raeburn 202: $metadatakeys{$unikey}.=','.$item;
1.139 albertel 203: } else {
1.294 raeburn 204: $metadatakeys{$unikey}=$item;
1.139 albertel 205: }
206: }
1.140 albertel 207: my $newentry=$parser->get_text('/'.$entry);
1.174 www 208: if (($entry eq 'customdistributionfile') ||
209: ($entry eq 'sourcerights')) {
1.140 albertel 210: $newentry=~s/^\s*//;
211: if ($newentry !~m|^/res|) { $newentry=$prefix.$newentry; }
212: }
1.149 www 213: # actually store
1.162 albertel 214: if ( $entry eq 'rule' && exists($metadatafields{$unikey})) {
215: $metadatafields{$unikey}.=','.$newentry;
216: } else {
217: $metadatafields{$unikey}=$newentry;
218: }
1.139 albertel 219: }
220: }
1.7 www 221: }
222:
1.90 matthew 223: #########################################
224: #########################################
225:
226: =pod
227:
1.94 harris41 228: =item B<metaread>
1.90 matthew 229:
230: Read a metadata file
231:
1.94 harris41 232: Parameters:
233:
234: =over
235:
236: =item I<$logfile>
237:
238: File output stream to output errors and warnings to.
239:
240: =item I<$fn>
241:
242: File name (including path).
243:
244: =back
245:
246: Returns:
247:
248: =over 4
249:
250: =item Scalar string (if successful)
251:
252: XHTML text that indicates successful reading of the metadata.
253:
254: =back
255:
1.90 matthew 256: =cut
257:
258: #########################################
259: #########################################
1.7 www 260: sub metaread {
1.140 albertel 261: my ($logfile,$fn,$prefix)=@_;
1.7 www 262: unless (-e $fn) {
1.94 harris41 263: print($logfile 'No file '.$fn."\n");
1.271 www 264: return '<p class="LC_warning">'
265: .&mt('No file: [_1]',&Apache::loncfile::display($fn))
266: .'</p>';
1.7 www 267: }
1.94 harris41 268: print($logfile 'Processing '.$fn."\n");
1.7 www 269: my $metastring;
270: {
1.140 albertel 271: my $metafh=Apache::File->new($fn);
272: $metastring=join('',<$metafh>);
1.7 www 273: }
1.140 albertel 274: &metaeval($metastring,$prefix);
1.271 www 275: return '<p class="LC_info">'
276: .&mt('Processed file: [_1]',&Apache::loncfile::display($fn))
277: .'</p>';
1.7 www 278: }
1.12 www 279:
1.90 matthew 280: #########################################
281: #########################################
282:
1.101 www 283: sub coursedependencies {
284: my $url=&Apache::lonnet::declutter(shift);
285: $url=~s/\.meta$//;
1.215 albertel 286: my ($adomain,$aauthor)=($url=~ m{^($match_domain)/($match_username)/});
287: my $regexp=quotemeta($url);
1.101 www 288: $regexp='___'.$regexp.'___course';
289: my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain,
290: $aauthor,$regexp);
291: my %courses=();
1.294 raeburn 292: foreach my $item (keys(%evaldata)) {
293: if ($item=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) {
1.101 www 294: $courses{$1}=1;
295: }
296: }
297: return %courses;
298: }
299: #########################################
300: #########################################
301:
302:
1.90 matthew 303: =pod
304:
1.94 harris41 305: =item Form-field-generating subroutines.
306:
307: For input parameters, these subroutines take in values
308: such as I<$name>, I<$value> and other form field metadata.
309: The output (scalar string that is returned) is an XHTML
310: string which presents the form field (foreseeably inside
311: <form></form> tags).
1.90 matthew 312:
313: =over 4
314:
1.94 harris41 315: =item B<textfield>
1.90 matthew 316:
1.295 raeburn 317: =item B<text_with_browse_field>
318:
1.94 harris41 319: =item B<hiddenfield>
1.90 matthew 320:
1.295 raeburn 321: =item B<checkbox>
322:
1.94 harris41 323: =item B<selectbox>
1.90 matthew 324:
325: =back
326:
327: =cut
328:
329: #########################################
330: #########################################
1.8 www 331: sub textfield {
1.301 raeburn 332: my ($title,$name,$value,$noline,$readonly)=@_;
1.141 www 333: $value=~s/^\s+//gs;
334: $value=~s/\s+$//gs;
335: $value=~s/\s+/ /gs;
1.134 www 336: $title=&mt($title);
1.192 albertel 337: $env{'form.'.$name}=$value;
1.238 bisitz 338: return "\n".&Apache::lonhtmlcommon::row_title($title)
339: .'<input type="text" name="'.$name.'" size="80" value="'.$value.'" />'
1.240 raeburn 340: .&Apache::lonhtmlcommon::row_closure($noline);
1.11 www 341: }
342:
1.180 albertel 343: sub text_with_browse_field {
1.301 raeburn 344: my ($title,$name,$value,$restriction,$noline,$readonly)=@_;
1.180 albertel 345: $value=~s/^\s+//gs;
346: $value=~s/\s+$//gs;
347: $value=~s/\s+/ /gs;
348: $title=&mt($title);
1.192 albertel 349: $env{'form.'.$name}=$value;
1.301 raeburn 350: my $disabled;
351: if ($readonly) {
352: $disabled = ' disabled="disabled"';
353: }
354: my $output =
355: "\n".&Apache::lonhtmlcommon::row_title($title)
356: .'<input type="text" name="'.$name.'" size="80" value="'.$value.'"'.$disabled.' />';
357: unless ($readonly) {
358: $output .=
359: '<br />'
1.238 bisitz 360: .'<a href="javascript:openbrowser(\'pubform\',\''.$name.'\',\''.$restriction.'\');">'
361: .&mt('Select')
362: .'</a> '
363: .'<a href="javascript:opensearcher(\'pubform\',\''.$name.'\');">'
364: .&mt('Search')
1.301 raeburn 365: .'</a>';
366: }
367: $output .= &Apache::lonhtmlcommon::row_closure($noline);
368: return $output;
1.180 albertel 369: }
370:
1.11 www 371: sub hiddenfield {
372: my ($name,$value)=@_;
1.192 albertel 373: $env{'form.'.$name}=$value;
1.94 harris41 374: return "\n".'<input type="hidden" name="'.$name.'" value="'.$value.'" />';
1.8 www 375: }
376:
1.193 www 377: sub checkbox {
378: my ($name,$text)=@_;
1.299 raeburn 379: return "\n<label><input type='checkbox' name='$name' /> ".
1.201 albertel 380: &mt($text)."</label>";
1.193 www 381: }
382:
1.9 www 383: sub selectbox {
1.301 raeburn 384: my ($title,$name,$value,$readonly,$functionref,@idlist)=@_;
1.134 www 385: $title=&mt($title);
1.123 albertel 386: $value=(split(/\s*,\s*/,$value))[-1];
1.167 albertel 387: if (defined($value)) {
1.192 albertel 388: $env{'form.'.$name}=$value;
1.167 albertel 389: } else {
1.192 albertel 390: $env{'form.'.$name}=$idlist[0];
1.167 albertel 391: }
1.238 bisitz 392: my $selout="\n".&Apache::lonhtmlcommon::row_title($title)
393: .'<select name="'.$name.'">';
1.294 raeburn 394: foreach my $id (@idlist) {
395: $selout.='<option value="'.$id.'"';
396: if ($id eq $value) {
1.257 bisitz 397: $selout.=' selected="selected"';
398: }
1.301 raeburn 399: if ($readonly) {
400: $selout .= ' disabled="disabled"';
401: }
1.294 raeburn 402: $selout.='>'.&{$functionref}($id).'</option>';
1.65 harris41 403: }
1.238 bisitz 404: $selout.='</select>'.&Apache::lonhtmlcommon::row_closure();
405: return $selout;
1.9 www 406: }
407:
1.167 albertel 408: sub select_level_form {
409: my ($value,$name)=@_;
1.192 albertel 410: $env{'form.'.$name}=$value;
411: if (!defined($value)) { $env{'form.'.$name}=0; }
1.167 albertel 412: return &Apache::loncommon::select_level_form($value,$name);
413: }
1.295 raeburn 414:
415: sub common_access {
416: my ($name,$text,$options)=@_;
417: return unless (ref($options) eq 'ARRAY');
418: my $formname = 'pubdirpref';
419: my $chkname = 'common'.$name;
420: my $chkid = 'LC_'.$chkname;
421: my $divid = $chkid.'div';
422: my $customdivid = 'LC_customfile';
423: my $selname = $chkname.'select';
424: my $selid = $chkid.'select';
425: my $selonchange;
426: if ($name eq 'dist') {
427: $selonchange = ' onchange="showHideCustom(this,'."'$customdivid'".');"';
428: }
429: my %lt = &Apache::lonlocal::texthash(
430: 'default' => 'System wide - can be used for any courses system wide',
431: 'domain' => 'Domain only - use limited to courses in the domai',
432: 'custom' => 'Customized right of use ...',
433: 'public' => 'Public - no authentication or authorization required for use',
434: 'closed' => 'Closed - XML source is closed to everyone',
435: 'open' => 'Open - XML source is open to people who want to use it',
436: 'sel' => 'Select',
437: );
438: my $output = <<"END";
439: <span class="LC_nobreak">
440: <label>
441: <input type="checkbox" name="commonaccess" value="$name" id="$chkid"
442: onclick="showHideAccess(this,'$divid');" />
443: $text</label></span>
444: <div id="$divid" style="padding:0;clear:both;margin:0;border:0;display:none">
445: <select name="$selname" id="$selid" $selonchange>
446: <option value="" selected="selected">$lt{'sel'}</option>
447: END
448: foreach my $val (@{$options}) {
449: $output .= '<option value="'.$val.'">'.$lt{$val}.'</option>'."\n";
450: }
451: $output .= '
452: </select>';
453: if ($name eq 'dist') {
454: $output .= <<"END";
455: <div id="$customdivid" style="padding:0;clear:both;margin:0;border:0;display:none">
456: <input type="text" name="commoncustomrights" size="60" value="" />
457: <a href="javascript:openbrowser('$formname','commoncustomrights','rights');">
458: $lt{'sel'}</a></div>
459: END
460: }
461: $output .= '
462: </div>
463: ';
464: }
465:
1.90 matthew 466: #########################################
467: #########################################
468:
469: =pod
470:
1.94 harris41 471: =item B<urlfixup>
1.90 matthew 472:
473: Fix up a url? First step of publication
1.12 www 474:
1.90 matthew 475: =cut
476:
477: #########################################
478: #########################################
1.34 www 479: sub urlfixup {
1.35 www 480: my ($url,$target)=@_;
1.39 www 481: unless ($url) { return ''; }
1.68 albertel 482: #javascript code needs no fixing
483: if ($url =~ /^javascript:/i) { return $url; }
1.69 albertel 484: if ($url =~ /^mailto:/i) { return $url; }
1.68 albertel 485: #internal document links need no fixing
486: if ($url =~ /^\#/) { return $url; }
1.223 albertel 487: my ($host)=($url=~m{(?:(?:http|https|ftp)://)*([^/]+)});
488: my @lonids = &Apache::lonnet::machine_ids($host);
489: if (@lonids) {
490: $url=~s{^(?:http|https|ftp)://}{};
491: $url=~s/^\Q$host\E//;
1.65 harris41 492: }
1.223 albertel 493: if ($url=~m{^(?:http|https|ftp)://}) { return $url; }
1.222 albertel 494: $url=~s{\Q~$cuname\E}{res/$cudom/$cuname};
1.71 www 495: return $url;
496: }
497:
1.90 matthew 498: #########################################
499: #########################################
500:
501: =pod
502:
1.94 harris41 503: =item B<absoluteurl>
1.90 matthew 504:
1.94 harris41 505: Currently undocumented.
1.90 matthew 506:
507: =cut
1.71 www 508:
1.90 matthew 509: #########################################
510: #########################################
1.71 www 511: sub absoluteurl {
512: my ($url,$target)=@_;
513: unless ($url) { return ''; }
1.35 www 514: if ($target) {
515: $target=~s/\/[^\/]+$//;
516: $url=&Apache::lonnet::hreflocation($target,$url);
517: }
518: return $url;
1.34 www 519: }
520:
1.90 matthew 521: #########################################
522: #########################################
523:
524: =pod
525:
1.94 harris41 526: =item B<set_allow>
1.90 matthew 527:
528: Currently undocumented
529:
530: =cut
531:
532: #########################################
533: #########################################
1.81 albertel 534: sub set_allow {
1.290 raeburn 535: my ($allow,$logfile,$target,$tag,$oldurl,$type)=@_;
1.81 albertel 536: my $newurl=&urlfixup($oldurl,$target);
537: my $return_url=$oldurl;
538: print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n";
539: if ($newurl ne $oldurl) {
540: $return_url=$newurl;
541: print $logfile 'URL: '.$tag.':'.$oldurl.' - '.$newurl."\n";
542: }
543: if (($newurl !~ /^javascript:/i) &&
544: ($newurl !~ /^mailto:/i) &&
1.220 albertel 545: ($newurl !~ /^(?:http|https|ftp):/i) &&
1.81 albertel 546: ($newurl !~ /^\#/)) {
1.290 raeburn 547: if (($type eq 'src') || ($type eq 'href')) {
548: if ($newurl =~ /^([^?]+)\?[^?]*$/) {
549: $newurl = $1;
550: }
551: }
1.81 albertel 552: $$allow{&absoluteurl($newurl,$target)}=1;
553: }
1.218 raeburn 554: return $return_url;
1.81 albertel 555: }
556:
1.90 matthew 557: #########################################
558: #########################################
559:
560: =pod
561:
1.94 harris41 562: =item B<get_subscribed_hosts>
1.90 matthew 563:
564: Currently undocumented
565:
566: =cut
567:
568: #########################################
569: #########################################
1.85 albertel 570: sub get_subscribed_hosts {
571: my ($target)=@_;
572: my @subscribed;
573: my $filename;
574: $target=~/(.*)\/([^\/]+)$/;
575: my $srcf=$2;
576: opendir(DIR,$1);
1.225 albertel 577: # cycle through listed files, subscriptions used to exist
578: # as "filename.lonid"
1.85 albertel 579: while ($filename=readdir(DIR)) {
1.216 albertel 580: if ($filename=~/\Q$srcf\E\.($match_lonid)$/) {
1.85 albertel 581: my $subhost=$1;
1.225 albertel 582: if (($subhost ne 'meta'
583: && $subhost ne 'subscription'
584: && $subhost ne 'meta.subscription'
585: && $subhost ne 'tmp') &&
1.98 www 586: ($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) {
1.85 albertel 587: push(@subscribed,$subhost);
588: }
589: }
590: }
591: closedir(DIR);
592: my $sh;
593: if ( $sh=Apache::File->new("$target.subscription") ) {
594: while (my $subline=<$sh>) {
1.216 albertel 595: if ($subline =~ /^($match_lonid):/) {
1.98 www 596: if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) {
597: push(@subscribed,$1);
598: }
1.85 albertel 599: }
600: }
601: }
602: return @subscribed;
603: }
604:
1.86 albertel 605:
1.90 matthew 606: #########################################
607: #########################################
608:
609: =pod
610:
1.94 harris41 611: =item B<get_max_ids_indices>
1.90 matthew 612:
613: Currently undocumented
614:
615: =cut
616:
617: #########################################
618: #########################################
1.86 albertel 619: sub get_max_ids_indices {
620: my ($content)=@_;
621: my $maxindex=10;
622: my $maxid=10;
623: my $needsfixup=0;
1.106 albertel 624: my $duplicateids=0;
625:
626: my %allids;
627: my %duplicatedids;
1.86 albertel 628:
629: my $parser=HTML::LCParser->new($content);
1.207 albertel 630: $parser->xml_mode(1);
1.86 albertel 631: my $token;
632: while ($token=$parser->get_token) {
633: if ($token->[0] eq 'S') {
634: my $counter;
635: if ($counter=$addid{$token->[1]}) {
636: if ($counter eq 'id') {
1.186 albertel 637: if (defined($token->[2]->{'id'}) &&
638: $token->[2]->{'id'} !~ /^\s*$/) {
1.86 albertel 639: $maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
1.106 albertel 640: if (exists($allids{$token->[2]->{'id'}})) {
641: $duplicateids=1;
642: $duplicatedids{$token->[2]->{'id'}}=1;
643: } else {
644: $allids{$token->[2]->{'id'}}=1;
645: }
1.86 albertel 646: } else {
647: $needsfixup=1;
648: }
649: } else {
1.186 albertel 650: if (defined($token->[2]->{'index'}) &&
651: $token->[2]->{'index'} !~ /^\s*$/) {
1.86 albertel 652: $maxindex=($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
653: } else {
654: $needsfixup=1;
655: }
656: }
657: }
658: }
659: }
1.106 albertel 660: return ($needsfixup,$maxid,$maxindex,$duplicateids,
661: (keys(%duplicatedids)));
1.86 albertel 662: }
663:
1.90 matthew 664: #########################################
665: #########################################
666:
667: =pod
668:
1.94 harris41 669: =item B<get_all_text_unbalanced>
1.90 matthew 670:
671: Currently undocumented
672:
673: =cut
674:
675: #########################################
676: #########################################
1.87 albertel 677: sub get_all_text_unbalanced {
678: #there is a copy of this in lonxml.pm
679: my($tag,$pars)= @_;
680: my $token;
681: my $result='';
682: $tag='<'.$tag.'>';
683: while ($token = $$pars[-1]->get_token) {
684: if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) {
685: $result.=$token->[1];
686: } elsif ($token->[0] eq 'PI') {
687: $result.=$token->[2];
688: } elsif ($token->[0] eq 'S') {
689: $result.=$token->[4];
690: } elsif ($token->[0] eq 'E') {
691: $result.=$token->[2];
692: }
1.177 albertel 693: if ($result =~ /\Q$tag\E/s) {
1.176 albertel 694: ($result,my $redo)=$result =~ /(.*)\Q$tag\E(.*)/is;
1.88 albertel 695: #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2);
696: #&Apache::lonnet::logthis('Result is :'.$1);
1.176 albertel 697: $redo=$tag.$redo;
1.87 albertel 698: push (@$pars,HTML::LCParser->new(\$redo));
699: $$pars[-1]->xml_mode('1');
700: last;
701: }
702: }
703: return $result
704: }
705:
1.90 matthew 706: #########################################
707: #########################################
708:
709: =pod
710:
1.94 harris41 711: =item B<fix_ids_and_indices>
1.90 matthew 712:
713: Currently undocumented
714:
715: =cut
716:
717: #########################################
718: #########################################
1.87 albertel 719: #Arguably this should all be done as a lonnet::ssi instead
1.86 albertel 720: sub fix_ids_and_indices {
721: my ($logfile,$source,$target)=@_;
722:
723: my %allow;
724: my $content;
725: {
726: my $org=Apache::File->new($source);
727: $content=join('',<$org>);
728: }
729:
1.106 albertel 730: my ($needsfixup,$maxid,$maxindex,$duplicateids,@duplicatedids)=
731: &get_max_ids_indices(\$content);
1.86 albertel 732:
1.106 albertel 733: print $logfile ("Got $needsfixup,$maxid,$maxindex,$duplicateids--".
734: join(', ',@duplicatedids));
735: if ($duplicateids) {
736: print $logfile "Duplicate ID(s) exist, ".join(', ',@duplicatedids)."\n";
1.226 albertel 737: 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>';
1.106 albertel 738: return ($outstring,1);
739: }
1.86 albertel 740: if ($needsfixup) {
741: print $logfile "Needs ID and/or index fixup\n".
742: "Max ID : $maxid (min 10)\n".
743: "Max Index: $maxindex (min 10)\n";
744: }
745: my $outstring='';
1.236 www 746: my $responsecounter=1;
1.86 albertel 747: my @parser;
748: $parser[0]=HTML::LCParser->new(\$content);
749: $parser[-1]->xml_mode(1);
750: my $token;
751: while (@parser) {
752: while ($token=$parser[-1]->get_token) {
753: if ($token->[0] eq 'S') {
754: my $counter;
755: my $tag=$token->[1];
756: my $lctag=lc($tag);
757: if ($lctag eq 'allow') {
758: $allow{$token->[2]->{'src'}}=1;
759: next;
760: }
1.202 albertel 761: if ($lctag eq 'base') { next; }
1.236 www 762: if (($lctag eq 'part') || ($lctag eq 'problem')) {
763: $responsecounter=0;
764: }
765: if ($lctag=~/response$/) { $responsecounter++; }
1.249 www 766: if ($lctag eq 'import') { $responsecounter++; }
1.86 albertel 767: my %parms=%{$token->[2]};
768: $counter=$addid{$tag};
769: if (!$counter) { $counter=$addid{$lctag}; }
770: if ($counter) {
771: if ($counter eq 'id') {
1.186 albertel 772: unless (defined($parms{'id'}) &&
773: $parms{'id'}!~/^\s*$/) {
1.86 albertel 774: $maxid++;
775: $parms{'id'}=$maxid;
1.205 albertel 776: print $logfile 'ID(new) : '.$tag.':'.$maxid."\n";
777: } else {
778: print $logfile 'ID(kept): '.$tag.':'.$parms{'id'}."\n";
1.86 albertel 779: }
780: } elsif ($counter eq 'index') {
1.186 albertel 781: unless (defined($parms{'index'}) &&
782: $parms{'index'}!~/^\s*$/) {
1.86 albertel 783: $maxindex++;
784: $parms{'index'}=$maxindex;
785: print $logfile 'Index: '.$tag.':'.$maxindex."\n";
786: }
787: }
788: }
1.203 www 789: unless ($parms{'type'} eq 'zombie') {
790: foreach my $type ('src','href','background','bgimg') {
791: foreach my $key (keys(%parms)) {
792: if ($key =~ /^$type$/i) {
1.292 raeburn 793: next if (($lctag eq 'img') && ($type eq 'src') &&
794: ($parms{$key} =~ m{^data\:image/gif;base64,}));
1.203 www 795: $parms{$key}=&set_allow(\%allow,$logfile,
796: $target,$tag,
1.290 raeburn 797: $parms{$key},$type);
1.203 www 798: }
1.86 albertel 799: }
800: }
801: }
802: # probably a <randomlabel> image type <label>
1.135 albertel 803: # or a <image> tag inside <imageresponse>
804: if (($lctag eq 'label' && defined($parms{'description'}))
805: ||
806: ($lctag eq 'image')) {
1.86 albertel 807: my $next_token=$parser[-1]->get_token();
808: if ($next_token->[0] eq 'T') {
1.218 raeburn 809: $next_token->[1] =~ s/[\n\r\f]+//g;
1.86 albertel 810: $next_token->[1]=&set_allow(\%allow,$logfile,
811: $target,$tag,
812: $next_token->[1]);
813: }
814: $parser[-1]->unget_token($next_token);
815: }
816: if ($lctag eq 'applet') {
817: my $codebase='';
1.148 albertel 818: my $havecodebase=0;
819: foreach my $key (keys(%parms)) {
820: if (lc($key) eq 'codebase') {
821: $codebase=$parms{$key};
822: $havecodebase=1;
823: }
824: }
825: if ($havecodebase) {
826: my $oldcodebase=$codebase;
1.86 albertel 827: unless ($oldcodebase=~/\/$/) {
828: $oldcodebase.='/';
829: }
830: $codebase=&urlfixup($oldcodebase,$target);
831: $codebase=~s/\/$//;
832: if ($codebase ne $oldcodebase) {
833: $parms{'codebase'}=$codebase;
834: print $logfile 'URL codebase: '.$tag.':'.
835: $oldcodebase.' - '.
836: $codebase."\n";
837: }
838: $allow{&absoluteurl($codebase,$target).'/*'}=1;
839: } else {
1.148 albertel 840: foreach my $key (keys(%parms)) {
841: if ($key =~ /(archive|code|object)/i) {
842: my $oldurl=$parms{$key};
1.86 albertel 843: my $newurl=&urlfixup($oldurl,$target);
844: $newurl=~s/\/[^\/]+$/\/\*/;
1.148 albertel 845: print $logfile 'Allow: applet '.lc($key).':'.
846: $oldurl.' allows '.$newurl."\n";
1.86 albertel 847: $allow{&absoluteurl($newurl,$target)}=1;
848: }
849: }
850: }
851: }
852: my $newparmstring='';
853: my $endtag='';
1.294 raeburn 854: foreach my $parkey (keys(%parms)) {
855: if ($parkey eq '/') {
1.86 albertel 856: $endtag=' /';
857: } else {
1.294 raeburn 858: my $quote=($parms{$parkey}=~/\"/?"'":'"');
859: $newparmstring.=' '.$parkey.'='.$quote.$parms{$parkey}.$quote;
1.86 albertel 860: }
861: }
862: if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
863: $outstring.='<'.$tag.$newparmstring.$endtag.'>';
1.286 raeburn 864: if ($lctag eq 'm' || $lctag eq 'answer' || $lctag eq 'display' ||
865: $lctag eq 'tex') {
1.130 albertel 866: $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser);
1.286 raeburn 867: } elsif ($lctag eq 'script') {
868: if ($parms{'type'} eq 'loncapa/perl') {
869: $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser);
870: } else {
871: my $script = &get_all_text_unbalanced('/'.$lctag,\@parser);
872: if ($script =~ m{\.set\w+(Src|Swf)\(["']}i) {
873: my @srcs = split(/\.set/i,$script);
874: if (scalar(@srcs) > 1) {
875: foreach my $item (@srcs) {
876: if ($item =~ m{^(FlashPlayerSwf|MediaSrc|XMPSrc|ConfigurationSrc|PosterImageSrc)\((['"])(?:(?!\2).)+\2\)}is) {
877: my $srctype = $1;
878: my $quote = $2;
879: my ($url) = ($item =~ m{^\Q$srctype($quote\E([^$quote]+)\Q$quote)\E});
880: $url = &urlfixup($url);
881: unless ($url=~m{^(?:http|https|ftp)://}) {
882: $allow{&absoluteurl($url,$target)}=1;
883: if ($srctype eq 'ConfigurationSrc') {
884: if ($url =~ m{^(.+/)configuration_express\.xml$}) {
885: #
886: # Camtasia 8.1: express_show/spritesheet.png needed, and included in zip archive.
887: # Not referenced directly in <main>.html or <main>_player.html files,
888: # so add this file to %allow (where <main> is name user gave to file/archive).
889: #
890: my $spritesheet = $1.'express_show/spritesheet.png';
891: $allow{&absoluteurl($spritesheet,$target)}=1;
1.293 raeburn 892:
893: #
894: # Camtasia 8.4: skins/express_show/spritesheet.min.css needed, and included in zip archive.
895: # Not referenced directly in <main>.html or <main>_player.html files,
896: # so add this file to %allow (where <main> is name user gave to file/archive).
897: #
898: my $spritecss = $1.'express_show/spritesheet.min.css';
899: $allow{&absoluteurl($spritecss,$target)}=1;
1.286 raeburn 900: }
901: } elsif ($srctype eq 'PosterImageSrc') {
902: if ($url =~ m{^(.+)_First_Frame\.png$}) {
903: my $prefix = $1;
904: #
905: # Camtasia 8.1: <main>_Thumbnails.png needed, and included in zip archive.
906: # Not referenced directly in <main>.html or <main>_player.html files,
907: # so add this file to %allow (where <main> is name user gave to file/archive).
908: #
909: my $thumbnail = $prefix.'_Thumbnails.png';
910: $allow{&absoluteurl($thumbnail,$target)}=1;
911: }
912: }
913: }
914: }
915: }
916: }
917: }
1.293 raeburn 918: if ($script =~ m{\.addMediaSrc\((["'])((?!\1).+)\1\);}) {
919: my $src = $2;
920: if ($src) {
921: my $url = &urlfixup($src);
922: unless ($url=~m{^(?:http|https|ftp)://}) {
923: $allow{&absoluteurl($url,$target)}=1;
924: }
925: }
926: }
1.291 raeburn 927: if ($script =~ /\(document,\s*(['"])script\1,\s*\[([^\]]+)\]\);/s) {
928: my $scriptslist = $2;
929: my @srcs = split(/\s*,\s*/,$scriptslist);
930: foreach my $src (@srcs) {
931: if ($src =~ /(["'])(?:(?!\1).)+\.js\1/) {
932: my $quote = $1;
933: my ($url) = ($src =~ m/\Q$quote\E([^$quote]+)\Q$quote\E/);
934: $url = &urlfixup($url);
935: unless ($url=~m{^(?:http|https|ftp)://}) {
936: $allow{&absoluteurl($url,$target)}=1;
937: }
938: }
939: }
940: }
1.293 raeburn 941: if ($script =~ m{loadScript\(\s*(['"])((?:(?!\1).)+\.js)\1,\s*function}is) {
942: my $src = $2;
943: if ($src) {
944: my $url = &urlfixup($src);
945: unless ($url=~m{^(?:http|https|ftp)://}) {
946: $allow{&absoluteurl($url,$target)}=1;
947: }
948: }
949: }
1.290 raeburn 950: $outstring .= $script;
1.286 raeburn 951: }
952: }
1.86 albertel 953: } elsif ($token->[0] eq 'E') {
954: if ($token->[2]) {
955: unless ($token->[1] eq 'allow') {
956: $outstring.='</'.$token->[1].'>';
957: }
1.236 www 958: }
959: if ((($token->[1] eq 'part') || ($token->[1] eq 'problem'))
960: && (!$responsecounter)) {
1.239 bisitz 961: my $outstring='<span class="LC_error">'.&mt('Found [_1] without responses. This resource cannot be published.',$token->[1]).'</span>';
1.236 www 962: return ($outstring,1);
963: }
1.86 albertel 964: } else {
965: $outstring.=$token->[1];
966: }
967: }
968: pop(@parser);
969: }
970:
971: if ($needsfixup) {
972: print $logfile "End of ID and/or index fixup\n".
973: "Max ID : $maxid (min 10)\n".
974: "Max Index: $maxindex (min 10)\n";
975: } else {
976: print $logfile "Does not need ID and/or index fixup\n";
977: }
978:
1.106 albertel 979: return ($outstring,0,%allow);
1.86 albertel 980: }
981:
1.89 matthew 982: #########################################
983: #########################################
984:
985: =pod
986:
1.94 harris41 987: =item B<store_metadata>
1.89 matthew 988:
989: Store the metadata in the metadata table in the loncapa database.
990: Uses lonmysql to access the database.
991:
992: Inputs: \%metadata
993:
994: Returns: (error,status). error is undef on success, status is undef on error.
995:
996: =cut
997:
998: #########################################
999: #########################################
1000: sub store_metadata {
1.151 www 1001: my %metadata = @_;
1.89 matthew 1002: my $error;
1003: # Determine if the table exists
1004: my $status = &Apache::lonmysql::check_table('metadata');
1005: if (! defined($status)) {
1.246 bisitz 1006: $error='<span class="LC_error">'
1007: .&mt('WARNING: Cannot connect to database!')
1008: .'</span>';
1.89 matthew 1009: &Apache::lonnet::logthis($error);
1010: return ($error,undef);
1011: }
1012: if ($status == 0) {
1013: # It would be nice to actually create the table....
1.246 bisitz 1014: $error ='<span class="LC_error">'
1015: .&mt('WARNING: The metadata table does not exist in the LON-CAPA database!')
1016: .'</span>';
1.89 matthew 1017: &Apache::lonnet::logthis($error);
1018: return ($error,undef);
1019: }
1.172 matthew 1020: my $dbh = &Apache::lonmysql::get_dbh();
1.237 www 1021: if (($metadata{'obsolete'}) || ($metadata{'copyright'} eq 'priv')) {
1.172 matthew 1022: # remove this entry
1.228 albertel 1023: my $delitem = 'url = '.$dbh->quote($metadata{'url'});
1024: $status = &LONCAPA::lonmetadata::delete_metadata($dbh,undef,$delitem);
1025:
1.152 www 1026: } else {
1.213 albertel 1027: $status = &LONCAPA::lonmetadata::update_metadata($dbh,undef,undef,
1.172 matthew 1028: \%metadata);
1.152 www 1029: }
1.172 matthew 1030: if (defined($status) && $status ne '') {
1.246 bisitz 1031: $error='<span class="LC_error">'
1.248 raeburn 1032: .&mt('Error occurred saving new values in metadata table in LON-CAPA database!')
1.246 bisitz 1033: .'</span>';
1.89 matthew 1034: &Apache::lonnet::logthis($error);
1.172 matthew 1035: &Apache::lonnet::logthis($status);
1.89 matthew 1036: return ($error,undef);
1037: }
1.213 albertel 1038: return (undef,'success');
1.89 matthew 1039: }
1040:
1.142 www 1041:
1.185 www 1042: # ========================================== Parse file for errors and warnings
1043:
1044: sub checkonthis {
1045: my ($r,$source)=@_;
1.187 www 1046: my $uri=&Apache::lonnet::hreflocation($source);
1047: $uri=~s/\/$//;
1.190 albertel 1048: my $result=&Apache::lonnet::ssi_body($uri,
1049: ('grade_target'=>'web',
1050: 'return_only_error_and_warning_counts' => 1));
1051: my ($errorcount,$warningcount)=split(':',$result);
1.187 www 1052: if (($errorcount) || ($warningcount)) {
1.242 bisitz 1053: $r->print('<h3>'.&mt('Warnings and Errors').'</h3>');
1054: $r->print('<tt>'.$uri.'</tt>:');
1055: $r->print('<ul>');
1056: if ($warningcount) {
1057: $r->print('<li><div class="LC_warning">'
1058: .&mt('[quant,_1,warning]',$warningcount)
1059: .'</div></li>');
1060: }
1061: if ($errorcount) {
1062: $r->print('<li><div class="LC_error">'
1063: .&mt('[quant,_1,error]',$errorcount)
1064: .' <img src="/adm/lonMisc/bomb.gif" />'
1065: .'</div></li>');
1066: }
1067: $r->print('</ul>');
1.185 www 1068: } else {
1.190 albertel 1069: #$r->print('<font color="green">'.&mt('ok').'</font>');
1.185 www 1070: }
1071: $r->rflush();
1.187 www 1072: return ($warningcount,$errorcount);
1.185 www 1073: }
1074:
1.142 www 1075: # ============================================== Parse file itself for metadata
1.144 www 1076: #
1077: # parses a file with target meta, sets global %metadatafields %metadatakeys
1.142 www 1078:
1079: sub parseformeta {
1080: my ($source,$style)=@_;
1.143 www 1081: my $allmeta='';
1.142 www 1082: if (($style eq 'ssi') || ($style eq 'prv')) {
1083: my $dir=$source;
1084: $dir=~s-/[^/]*$--;
1085: my $file=$source;
1086: $file=(split('/',$file))[-1];
1087: $source=&Apache::lonnet::hreflocation($dir,$file);
1.143 www 1088: $allmeta=&Apache::lonnet::ssi_body($source,('grade_target' => 'meta'));
1.142 www 1089: &metaeval($allmeta);
1090: }
1.143 www 1091: return $allmeta;
1.142 www 1092: }
1093:
1.90 matthew 1094: #########################################
1095: #########################################
1096:
1097: =pod
1098:
1.94 harris41 1099: =item B<publish>
1100:
1101: This is the workhorse function of this module. This subroutine generates
1102: backup copies, performs any automatic processing (prior to publication,
1103: especially for rat and ssi files),
1.90 matthew 1104:
1.113 albertel 1105: Returns a 2 element array, the first is the string to be shown to the
1.248 raeburn 1106: user, the second is an error code, either 1 (an error occurred) or 0
1.113 albertel 1107: (no error occurred)
1108:
1.94 harris41 1109: I<Additional documentation needed.>
1.90 matthew 1110:
1111: =cut
1112:
1113: #########################################
1114: #########################################
1.2 www 1115: sub publish {
1.50 www 1116:
1.296 raeburn 1117: my ($source,$target,$style,$batch,$nokeyref)=@_;
1.2 www 1118: my $logfile;
1.4 www 1119: my $scrout='';
1.23 www 1120: my $allmeta='';
1121: my $content='';
1.36 www 1122: my %allow=();
1.4 www 1123:
1.2 www 1124: unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
1.226 albertel 1125: return ('<span class="LC_error">'.&mt('No write permission to user directory, FAIL').'</span>',1);
1.2 www 1126: }
1127: print $logfile
1.211 albertel 1128: "\n\n================= Publish ".localtime()." Phase One ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n";
1.2 www 1129:
1.119 www 1130: if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) {
1.3 www 1131: # ------------------------------------------------------- This needs processing
1.4 www 1132:
1133: # ----------------------------------------------------------------- Backup Copy
1.3 www 1134: my $copyfile=$source.'.save';
1.13 www 1135: if (copy($source,$copyfile)) {
1.3 www 1136: print $logfile "Copied original file to ".$copyfile."\n";
1137: } else {
1.13 www 1138: print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";
1.239 bisitz 1139: return ("<span class=\"LC_error\">".&mt("Failed to write backup copy, [_1], FAIL",$1)."</span>",1);
1.3 www 1140: }
1.4 www 1141: # ------------------------------------------------------------- IDs and indices
1.86 albertel 1142:
1.106 albertel 1143: my ($outstring,$error);
1144: ($outstring,$error,%allow)=&fix_ids_and_indices($logfile,$source,
1145: $target);
1.113 albertel 1146: if ($error) { return ($outstring,$error); }
1.36 www 1147: # ------------------------------------------------------------ Construct Allows
1.62 www 1148:
1.246 bisitz 1149: my $outdep=''; # Collect dependencies output data
1.62 www 1150: my $allowstr='';
1.232 raeburn 1151: foreach my $thisdep (sort(keys(%allow))) {
1.73 albertel 1152: if ($thisdep !~ /[^\s]/) { next; }
1.231 www 1153: if ($thisdep =~/\$/) {
1.246 bisitz 1154: $outdep.='<div class="LC_warning">'
1.232 raeburn 1155: .&mt('The resource depends on another resource with variable filename, i.e., [_1].','<tt>'.$thisdep.'</tt>').'<br />'
1156: .&mt('You likely need to explicitly allow access to all possible dependencies using the [_1]-tag.','<tt><allow></tt>')
1.246 bisitz 1157: ."</div>\n";
1.231 www 1158: }
1.62 www 1159: unless ($style eq 'rat') {
1160: $allowstr.="\n".'<allow src="'.$thisdep.'" />';
1161: }
1.246 bisitz 1162: $outdep.='<div>';
1.231 www 1163: if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) {
1.246 bisitz 1164: $outdep.='<a href="'.$thisdep.'">';
1.44 www 1165: }
1.246 bisitz 1166: $outdep.='<tt>'.$thisdep.'</tt>';
1.231 www 1167: if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) {
1.246 bisitz 1168: $outdep.='</a>';
1.59 www 1169: if (
1170: &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
1171: $thisdep.'.meta') eq '-1') {
1.246 bisitz 1172: $outdep.= ' - <span class="LC_error">'.&mt('Currently not available').
1.226 albertel 1173: '</span>';
1.59 www 1174: } else {
1.279 www 1175: #
1176: # Store the fact that the dependency has been used by the target file
1177: # Unfortunately, usage is erroneously named sequsage in lonmeta.pm
1178: # The translation happens in lonmetadata.pm
1179: #
1.59 www 1180: my %temphash=(&Apache::lonnet::declutter($target).'___'.
1181: &Apache::lonnet::declutter($thisdep).'___usage'
1182: => time);
1.215 albertel 1183: $thisdep=~m{^/res/($match_domain)/($match_username)/};
1.59 www 1184: if ((defined($1)) && (defined($2))) {
1.92 albertel 1185: &Apache::lonnet::put('nohist_resevaldata',\%temphash,
1186: $1,$2);
1.59 www 1187: }
1188: }
1.44 www 1189: }
1.246 bisitz 1190: $outdep.='</div><br />';
1191: }
1192:
1193: if ($outdep) {
1194: $scrout.='<h3>'.&mt('Dependencies').'</h3>'
1195: .$outdep
1.65 harris41 1196: }
1.175 albertel 1197: $outstring=~s/\n*(\<\/[^\>]+\>[^<]*)$/$allowstr\n$1\n/s;
1.62 www 1198:
1.94 harris41 1199: # ------------------------------------------------------------- Write modified.
1.37 www 1200:
1.4 www 1201: {
1202: my $org;
1203: unless ($org=Apache::File->new('>'.$source)) {
1204: print $logfile "No write permit to $source\n";
1.226 albertel 1205: return ('<span class="LC_error">'.&mt('No write permission to').
1.136 www 1206: ' '.$source.
1.226 albertel 1207: ', '.&mt('FAIL').'</span>',1);
1.4 www 1208: }
1.94 harris41 1209: print($org $outstring);
1.4 www 1210: }
1211: $content=$outstring;
1.34 www 1212:
1.37 www 1213: }
1.301 raeburn 1214:
1215: # ----------------------------------------------------- Course Authoring Space.
1216: my ($courseauthor,$crsaurights,$readonly);
1217: if ($env{'request.course.id'}) {
1218: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
1219: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
1220: my $docroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1221: if ($source =~ m{^\Q$docroot/priv/$cdom/$cnum/\E}) {
1222: $courseauthor = $cnum.':'.$cdom;
1223: $crsaurights = "/res/$cdom/$cnum/default.rights";
1224: $readonly = 1;
1225: }
1226: }
1227:
1.94 harris41 1228: # -------------------------------------------- Initial step done, now metadata.
1.7 www 1229:
1.94 harris41 1230: # --------------------------------------- Storage for metadata keys and fields.
1.144 www 1231: # these are globals
1232: #
1.8 www 1233: %metadatafields=();
1234: %metadatakeys=();
1235:
1236: my %oldparmstores=();
1.44 www 1237:
1.97 www 1238: unless ($batch) {
1.254 bisitz 1239: $scrout.='<h3>'.&mt('Metadata').' ' .
1.239 bisitz 1240: &Apache::loncommon::help_open_topic("Metadata_Description")
1.84 bowersj2 1241: . '</h3>';
1.97 www 1242: }
1.7 www 1243:
1244: # ------------------------------------------------ First, check out environment
1.195 www 1245: if ((!(-e $source.'.meta')) || ($env{'form.forceoverride'})) {
1.192 albertel 1246: $metadatafields{'author'}=$env{'environment.firstname'}.' '.
1247: $env{'environment.middlename'}.' '.
1248: $env{'environment.lastname'}.' '.
1249: $env{'environment.generation'};
1.8 www 1250: $metadatafields{'author'}=~s/\s+/ /g;
1251: $metadatafields{'author'}=~s/\s+$//;
1.211 albertel 1252: $metadatafields{'owner'}=$cuname.':'.$cudom;
1.7 www 1253:
1254: # ------------------------------------------------ Check out directory hierachy
1255:
1256: my $thisdisfn=$source;
1257:
1.269 www 1258: $thisdisfn=~s/^\Q$docroot\E\/priv\/\Q$cudom\E\/\Q$cuname\E\///;
1259: my @urlparts=('.',split(/\//,$thisdisfn));
1.7 www 1260: $#urlparts--;
1261:
1.269 www 1262: my $currentpath=$docroot.'/priv/'.$cudom.'/'.$cuname.'/';
1.7 www 1263:
1.140 albertel 1264: my $prefix='../'x($#urlparts);
1.269 www 1265: foreach my $subdir (@urlparts) {
1266: $currentpath.=$subdir.'/';
1.140 albertel 1267: $scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix);
1268: $prefix=~s|^\.\./||;
1.65 harris41 1269: }
1.185 www 1270:
1.149 www 1271: # ----------------------------------------------------------- Parse file itself
1272: # read %metadatafields from file itself
1273:
1274: $allmeta=&parseformeta($source,$style);
1.7 www 1275:
1276: # ------------------- Clear out parameters and stores (there should not be any)
1277:
1.294 raeburn 1278: foreach my $field (keys(%metadatafields)) {
1279: if (($field=~/^parameter/) || ($field=~/^stores/)) {
1280: delete $metadatafields{$field};
1.7 www 1281: }
1.65 harris41 1282: }
1.7 www 1283:
1.8 www 1284: } else {
1.7 www 1285: # ---------------------- Read previous metafile, remember parameters and stores
1286:
1287: $scrout.=&metaread($logfile,$source.'.meta');
1288:
1.294 raeburn 1289: foreach my $field (keys(%metadatafields)) {
1290: if (($field=~/^parameter/) || ($field=~/^stores/)) {
1291: $oldparmstores{$field}=1;
1292: delete $metadatafields{$field};
1.7 www 1293: }
1.65 harris41 1294: }
1.195 www 1295: # ------------------------------------------------------------- Save some stuff
1296: my %savemeta=();
1.294 raeburn 1297: if ($metadatafields{'title'}) { $savemeta{'title'}=$metadatafields{'title'}; }
1.161 albertel 1298: # ------------------------------------------ See if anything new in file itself
1299:
1300: $allmeta=&parseformeta($source,$style);
1.195 www 1301: # ----------------------------------------------------------- Restore the stuff
1.294 raeburn 1302: foreach my $item (keys(%savemeta)) {
1303: $metadatafields{$item}=$savemeta{$item};
1.195 www 1304: }
1.144 www 1305: }
1.7 www 1306:
1.144 www 1307:
1.7 www 1308: # ---------------- Find and document discrepancies in the parameters and stores
1309:
1.116 albertel 1310: my $chparms='';
1.294 raeburn 1311: foreach my $field (sort(keys(%metadatafields))) {
1312: if (($field=~/^parameter/) || ($field=~/^stores/)) {
1313: unless ($field=~/\.\w+$/) {
1314: unless ($oldparmstores{$field}) {
1315: my $disp_key = $field;
1.219 albertel 1316: $disp_key =~ tr/\0/_/;
1317: print $logfile ('New: '.$disp_key."\n");
1318: $chparms .= $disp_key.' ';
1.116 albertel 1319: }
1320: }
1321: }
1322: }
1323: if ($chparms) {
1.224 albertel 1324: $scrout.='<p><b>'.&mt('New parameters or saved values').
1.136 www 1325: ':</b> '.$chparms.'</p>';
1.116 albertel 1326: }
1.7 www 1327:
1.116 albertel 1328: $chparms='';
1.294 raeburn 1329: foreach my $olditem (sort(keys(%oldparmstores))) {
1330: if (($olditem=~/^parameter/) || ($olditem=~/^stores/)) {
1331: unless (($metadatafields{$olditem.'.name'}) ||
1332: ($metadatafields{$olditem.'.package'}) || ($olditem=~/\.\w+$/)) {
1333: my $disp_key = $olditem;
1.219 albertel 1334: $disp_key =~ tr/\0/_/;
1335: print $logfile ('Obsolete: '.$disp_key."\n");
1336: $chparms.=$disp_key.' ';
1.116 albertel 1337: }
1338: }
1339: }
1340: if ($chparms) {
1.258 bisitz 1341: $scrout.='<p><b>'.&mt('Obsolete parameters or saved values').':</b> '
1342: .$chparms.'</p>'
1343: .'<p class="LC_warning"><b>'.&mt('Warning!').'</b><br />'
1344: .&mt('If this resource is in active use, student performance data from the previous version may become inaccessible.')
1345: .'</p><hr />';
1.116 albertel 1346: }
1.229 www 1347: if ($metadatafields{'copyright'} eq 'priv') {
1.258 bisitz 1348: $scrout.='<p class="LC_warning"><b>'.&mt('Warning!').'</b><br />'
1349: .&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.')
1350: .'</p><hr />';
1.229 www 1351: }
1.37 www 1352:
1.8 www 1353: # ------------------------------------------------------- Now have all metadata
1.5 www 1354:
1.116 albertel 1355: my %keywords=();
1.97 www 1356:
1.116 albertel 1357: if (length($content)<500000) {
1358: my $textonly=$content;
1359: $textonly=~s/\<script[^\<]+\<\/script\>//g;
1360: $textonly=~s/\<m\>[^\<]+\<\/m\>//g;
1361: $textonly=~s/\<[^\>]*\>//g;
1.245 onken 1362:
1363: #this is a work simplification for german authors for present
1364: $textonly=HTML::Entities::decode($textonly); #decode HTML-character
1365: $textonly=Encode::Encoder::encode('utf8', $textonly); #encode to perl internal unicode
1366: $textonly=~tr/A-ZÜÄÖ/a-züäö/; #add lowercase rule for german "Umlaute"
1367: $textonly=~s/[\$\&][a-z]\w*//g;
1368: $textonly=~s/[^a-z^ü^ä^ö^ß\s]//g; #dont delete german "Umlaute"
1369:
1370: foreach ($textonly=~m/[^\s]+/g) { #match all but whitespaces
1.296 raeburn 1371: unless ($nokeyref->{$_}) {
1.245 onken 1372: $keywords{$_}=1;
1373: }
1374: }
1375:
1376:
1.116 albertel 1377: }
1.97 www 1378:
1.168 www 1379: foreach my $addkey (split(/[\"\'\,\;]/,$metadatafields{'keywords'})) {
1380: $addkey=~s/\s+/ /g;
1381: $addkey=~s/^\s//;
1382: $addkey=~s/\s$//;
1383: if ($addkey=~/\w/) {
1384: $keywords{$addkey}=1;
1385: }
1.116 albertel 1386: }
1.97 www 1387: # --------------------------------------------------- Now we also have keywords
1388: # =============================================================================
1.167 albertel 1389: # interactive mode html goes into $intr_scrout
1390: # batch mode throws away this HTML
1391: # additionally all of the field functions have a by product of setting
1.192 albertel 1392: # $env{'from.'..} so that it can be used by the phase two handler in
1.167 albertel 1393: # batch mode
1394:
1.239 bisitz 1395: my $intr_scrout.='<br />'
1.238 bisitz 1396: .'<form name="pubform" action="/adm/publish" method="post">';
1397: unless ($env{'form.makeobsolete'}) {
1.246 bisitz 1398: $intr_scrout.='<p class="LC_warning">'
1.239 bisitz 1399: .&mt('Searching for your resource will be based on the following metadata. Please provide as much data as possible.')
1400: .'</p>'
1401: .'<p><input type="submit" value="'
1.238 bisitz 1402: .&mt('Finalize Publication')
1.271 www 1403: .'" /> <a href="'.&Apache::loncfile::url($source).'">'.&mt('Cancel').'</a></p>';
1.238 bisitz 1404: }
1.239 bisitz 1405: $intr_scrout.=&Apache::lonhtmlcommon::start_pick_box();
1.238 bisitz 1406: $intr_scrout.=
1.167 albertel 1407: &hiddenfield('phase','two').
1.192 albertel 1408: &hiddenfield('filename',$env{'form.filename'}).
1.209 www 1409: &hiddenfield('allmeta',&escape($allmeta)).
1.294 raeburn 1410: &hiddenfield('dependencies',join(',',keys(%allow)));
1.194 www 1411: unless ($env{'form.makeobsolete'}) {
1412: $intr_scrout.=
1.167 albertel 1413: &textfield('Title','title',$metadatafields{'title'}).
1414: &textfield('Author(s)','author',$metadatafields{'author'}).
1415: &textfield('Subject','subject',$metadatafields{'subject'});
1.194 www 1416: # --------------------------------------------------- Scan content for keywords
1.7 www 1417:
1.238 bisitz 1418: my $keywords_help = &Apache::loncommon::help_open_topic("Publishing_Keywords");
1.167 albertel 1419: my $keywordout=<<"END";
1.77 matthew 1420: <script>
1.116 albertel 1421: function checkAll(field) {
1.77 matthew 1422: for (i = 0; i < field.length; i++)
1423: field[i].checked = true ;
1424: }
1425:
1.116 albertel 1426: function uncheckAll(field) {
1.77 matthew 1427: for (i = 0; i < field.length; i++)
1428: field[i].checked = false ;
1429: }
1430: </script>
1.117 albertel 1431: END
1.238 bisitz 1432: $keywordout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Keywords'))
1433: .$keywords_help
1434: .'<input type="button" value="'.&mt('check all').'" onclick="javascript:checkAll(document.pubform.keywords)" />'
1435: .'<input type="button" value="'.&mt('uncheck all').'" onclick="javascript:uncheckAll(document.pubform.keywords)" />'
1436: .'</p><br />'
1.247 raeburn 1437: .&Apache::loncommon::start_data_table();
1438: my $cols_per_row = 10;
1.167 albertel 1439: my $colcount=0;
1.247 raeburn 1440: my $wordcount=0;
1441: my $numkeywords = scalar(keys(%keywords));
1.116 albertel 1442:
1.247 raeburn 1443: foreach my $word (sort(keys(%keywords))) {
1444: if ($colcount == 0) {
1445: $keywordout .= &Apache::loncommon::start_data_table_row();
1446: }
1447: $colcount++;
1448: $wordcount++;
1449: if (($wordcount == $numkeywords) && ($colcount < $cols_per_row)) {
1450: my $colspan = 1+$cols_per_row-$colcount;
1451: $keywordout .= '<td colspan="'.$colspan.'">';
1452: } else {
1453: $keywordout .= '<td>';
1454: }
1455: $keywordout.='<label><input type="checkbox" name="keywords" value="'.$word.'"';
1456: if ($metadatafields{'keywords'}) {
1457: if ($metadatafields{'keywords'}=~/\Q$word\E/) {
1.253 bisitz 1458: $keywordout.=' checked="checked"';
1.247 raeburn 1459: $env{'form.keywords'}.=$word.',';
1460: }
1461: } elsif (&Apache::loncommon::keyword($word)) {
1.253 bisitz 1462: $keywordout.=' checked="checked"';
1.247 raeburn 1463: $env{'form.keywords'}.=$word.',';
1464: }
1465: $keywordout.=' />'.$word.'</label></td>';
1466: if ($colcount == $cols_per_row) {
1467: $keywordout.=&Apache::loncommon::end_data_table_row();
1468: $colcount=0;
1.243 bisitz 1469: }
1470: }
1.247 raeburn 1471: if ($colcount > 0) {
1472: $keywordout .= &Apache::loncommon::end_data_table_row();
1473: }
1.243 bisitz 1474:
1.192 albertel 1475: $env{'form.keywords'}=~s/\,$//;
1.116 albertel 1476:
1.241 raeburn 1477: $keywordout.=&Apache::loncommon::end_data_table_row()
1478: .&Apache::loncommon::end_data_table()
1.238 bisitz 1479: .&Apache::lonhtmlcommon::row_closure();
1.51 www 1480:
1.167 albertel 1481: $intr_scrout.=$keywordout;
1.9 www 1482:
1.167 albertel 1483: $intr_scrout.=&textfield('Additional Keywords','addkey','');
1.12 www 1484:
1.167 albertel 1485: $intr_scrout.=&textfield('Notes','notes',$metadatafields{'notes'});
1.9 www 1486:
1.238 bisitz 1487: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Abstract'))
1488: .'<textarea cols="80" rows="5" name="abstract">'
1489: .$metadatafields{'abstract'}
1490: .'</textarea>'
1491: .&Apache::lonhtmlcommon::row_closure();
1.9 www 1492:
1.167 albertel 1493: $source=~/\.(\w+)$/;
1.150 www 1494:
1.238 bisitz 1495: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Grade Levels'))
1496: .&mt('Lowest Grade Level:').' '
1497: .&select_level_form($metadatafields{'lowestgradelevel'},'lowestgradelevel')
1498: # .&Apache::lonhtmlcommon::row_closure();
1499: # $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Highest Grade Level'))
1500: .' '.&mt('Highest Grade Level:').' '
1501: .&select_level_form($metadatafields{'highestgradelevel'},'highestgradelevel')
1502: .&Apache::lonhtmlcommon::row_closure();
1.150 www 1503:
1.238 bisitz 1504: $intr_scrout.=&textfield('Standards','standards',$metadatafields{'standards'});
1.11 www 1505:
1.167 albertel 1506: $intr_scrout.=&hiddenfield('mime',$1);
1.11 www 1507:
1.167 albertel 1508: my $defaultlanguage=$metadatafields{'language'};
1509: $defaultlanguage =~ s/\s*notset\s*//g;
1510: $defaultlanguage =~ s/^,\s*//g;
1511: $defaultlanguage =~ s/,\s*$//g;
1.123 albertel 1512:
1.167 albertel 1513: $intr_scrout.=&selectbox('Language','language',
1.301 raeburn 1514: $defaultlanguage,'',
1.167 albertel 1515: \&Apache::loncommon::languagedescription,
1516: (&Apache::loncommon::languageids),
1517: );
1.11 www 1518:
1.167 albertel 1519: unless ($metadatafields{'creationdate'}) {
1520: $metadatafields{'creationdate'}=time;
1521: }
1522: $intr_scrout.=&hiddenfield('creationdate',
1523: &Apache::lonmysql::unsqltime($metadatafields{'creationdate'}));
1.116 albertel 1524:
1.167 albertel 1525: $intr_scrout.=&hiddenfield('lastrevisiondate',time);
1.11 www 1526:
1.240 raeburn 1527: my $pubowner_last;
1528: if ($style eq 'prv') {
1529: $pubowner_last = 1;
1530: }
1.301 raeburn 1531: if ($courseauthor) {
1532: $metadatafields{'owner'} = $courseauthor;
1533: }
1.167 albertel 1534: $intr_scrout.=&textfield('Publisher/Owner','owner',
1.301 raeburn 1535: $metadatafields{'owner'},$pubowner_last,$readonly);
1.84 bowersj2 1536:
1.173 www 1537: # ---------------------------------------------- Retrofix for unused copyright
1538: if ($metadatafields{'copyright'} eq 'free') {
1539: $metadatafields{'copyright'}='default';
1540: $metadatafields{'sourceavail'}='open';
1541: }
1.229 www 1542: if ($metadatafields{'copyright'} eq 'priv') {
1543: $metadatafields{'copyright'}='domain';
1544: }
1.174 www 1545: # ------------------------------------------------ Dial in reasonable defaults
1.167 albertel 1546: my $defaultoption=$metadatafields{'copyright'};
1547: unless ($defaultoption) { $defaultoption='default'; }
1.301 raeburn 1548: if ($courseauthor) {
1549: $defaultoption='custom';
1550: $metadatafields{'customdistributionfile'}=$crsaurights;
1551: }
1.174 www 1552: my $defaultsourceoption=$metadatafields{'sourceavail'};
1553: unless ($defaultsourceoption) { $defaultsourceoption='closed'; }
1.167 albertel 1554: unless ($style eq 'prv') {
1.174 www 1555: # -------------------------------------------------- Correct copyright for rat.
1.167 albertel 1556: if ($style eq 'rat') {
1.174 www 1557: # -------------------------------------- Retrofix for non-applicable copyright
1.167 albertel 1558: if ($metadatafields{'copyright'} eq 'public') {
1559: delete $metadatafields{'copyright'};
1560: $defaultoption='default';
1561: }
1562: $intr_scrout.=&selectbox('Copyright/Distribution','copyright',
1.301 raeburn 1563: $defaultoption,$readonly,
1.167 albertel 1564: \&Apache::loncommon::copyrightdescription,
1.229 www 1565: (grep !/^(public|priv)$/,(&Apache::loncommon::copyrightids)));
1.116 albertel 1566: } else {
1.174 www 1567: $intr_scrout.=&selectbox('Copyright/Distribution','copyright',
1.301 raeburn 1568: $defaultoption,$readonly,
1.174 www 1569: \&Apache::loncommon::copyrightdescription,
1.229 www 1570: (grep !/^priv$/,(&Apache::loncommon::copyrightids)));
1.65 harris41 1571: }
1.174 www 1572: my $copyright_help =
1.238 bisitz 1573: &Apache::loncommon::help_open_topic('Publishing_Copyright');
1574: my $replace=&mt('Copyright/Distribution:');
1575: $intr_scrout =~ s/$replace/$replace.' '.$copyright_help/ge;
1576:
1.301 raeburn 1577: $intr_scrout.=&text_with_browse_field('Custom Distribution File','customdistributionfile',$metadatafields{'customdistributionfile'},'rights','',$readonly);
1.174 www 1578: $intr_scrout.=&selectbox('Source Distribution','sourceavail',
1.301 raeburn 1579: $defaultsourceoption,'',
1.174 www 1580: \&Apache::loncommon::source_copyrightdescription,
1581: (&Apache::loncommon::source_copyrightids));
1.198 www 1582: # $intr_scrout.=&text_with_browse_field('Source Custom Distribution File','sourcerights',$metadatafields{'sourcerights'},'rights');
1.174 www 1583: my $uctitle=&mt('Obsolete');
1.257 bisitz 1584: my $obsolete_checked=($metadatafields{'obsolete'})?' checked="checked"':'';
1.238 bisitz 1585: $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title($uctitle)
1.256 bisitz 1586: .'<input type="checkbox" name="obsolete"'.$obsolete_checked.' />'
1.238 bisitz 1587: .&Apache::lonhtmlcommon::row_closure(1);
1588: $intr_scrout.=&text_with_browse_field('Suggested Replacement for Obsolete File',
1.180 albertel 1589: 'obsoletereplacement',
1.240 raeburn 1590: $metadatafields{'obsoletereplacement'},'',1);
1.174 www 1591: } else {
1592: $intr_scrout.=&hiddenfield('copyright','private');
1593: }
1.194 www 1594: } else {
1595: $intr_scrout.=
1596: &hiddenfield('title',$metadatafields{'title'}).
1597: &hiddenfield('author',$metadatafields{'author'}).
1598: &hiddenfield('subject',$metadatafields{'subject'}).
1599: &hiddenfield('keywords',$metadatafields{'keywords'}).
1600: &hiddenfield('abstract',$metadatafields{'abstract'}).
1601: &hiddenfield('notes',$metadatafields{'notes'}).
1602: &hiddenfield('mime',$metadatafields{'mime'}).
1603: &hiddenfield('creationdate',$metadatafields{'creationdate'}).
1604: &hiddenfield('lastrevisiondate',time).
1605: &hiddenfield('owner',$metadatafields{'owner'}).
1606: &hiddenfield('lowestgradelevel',$metadatafields{'lowestgradelevel'}).
1607: &hiddenfield('standards',$metadatafields{'standards'}).
1608: &hiddenfield('highestgradelevel',$metadatafields{'highestgradelevel'}).
1609: &hiddenfield('language',$metadatafields{'language'}).
1610: &hiddenfield('copyright',$metadatafields{'copyright'}).
1611: &hiddenfield('sourceavail',$metadatafields{'sourceavail'}).
1612: &hiddenfield('customdistributionfile',$metadatafields{'customdistributionfile'}).
1.195 www 1613: &hiddenfield('obsolete',1).
1.194 www 1614: &text_with_browse_field('Suggested Replacement for Obsolete File',
1615: 'obsoletereplacement',
1.240 raeburn 1616: $metadatafields{'obsoletereplacement'},'',1);
1.194 www 1617: }
1.167 albertel 1618: if (!$batch) {
1.238 bisitz 1619: $scrout.=$intr_scrout
1.239 bisitz 1620: .&Apache::lonhtmlcommon::end_pick_box()
1621: .'<p><input type="submit" value="'
1.238 bisitz 1622: .&mt($env{'form.makeobsolete'}?'Make Obsolete':'Finalize Publication')
1.239 bisitz 1623: .'" /></p>'
1624: .'</form>';
1.97 www 1625: }
1.167 albertel 1626: return($scrout,0);
1.2 www 1627: }
1.1 www 1628:
1.296 raeburn 1629: sub getnokey {
1630: my ($includedir) = @_;
1631: my $nokey={};
1632: my $fh=Apache::File->new($includedir.'/un_keyword.tab');
1633: while (<$fh>) {
1634: my $word=$_;
1635: chomp($word);
1636: $nokey->{$word}=1;
1637: }
1638: return $nokey;
1639: }
1640:
1.90 matthew 1641: #########################################
1642: #########################################
1643:
1644: =pod
1645:
1.94 harris41 1646: =item B<phasetwo>
1.90 matthew 1647:
1648: Render second interface showing status of publication steps.
1649: This is publication step two.
1650:
1.94 harris41 1651: Parameters:
1652:
1653: =over 4
1654:
1655: =item I<$source>
1656:
1657: =item I<$target>
1658:
1659: =item I<$style>
1660:
1661: =item I<$distarget>
1662:
1.296 raeburn 1663: =item I<$batch>
1664:
1665: =item I<$usebuffer>
1666:
1.94 harris41 1667: =back
1668:
1669: Returns:
1670:
1671: =over 4
1672:
1.296 raeburn 1673: =item integer or array
1674:
1675: if $userbuffer arg is true, and if caller wants an array
1676: then the array ($output,$rtncode) will be returned, otherwise
1677: just the $rtncode will be returned. $rtncode is an integer:
1.94 harris41 1678:
1.197 www 1679: 0: fail
1680: 1: success
1.94 harris41 1681:
1.288 raeburn 1682: =back
1683:
1.90 matthew 1684: =cut
1.12 www 1685:
1.100 matthew 1686: #'stupid emacs
1.90 matthew 1687: #########################################
1688: #########################################
1.11 www 1689: sub phasetwo {
1690:
1.296 raeburn 1691: my ($r,$source,$target,$style,$distarget,$batch,$usebuffer)=@_;
1.102 www 1692: $source=~s/\/+/\//g;
1693: $target=~s/\/+/\//g;
1.196 www 1694: #
1695: # Unless trying to get rid of something, check name validity
1696: #
1.296 raeburn 1697: my $output;
1.196 www 1698: unless ($env{'form.obsolete'}) {
1699: if ($target=~/(\_\_\_|\&\&\&|\:\:\:)/) {
1.296 raeburn 1700: $output = '<span class="LC_error">'.
1.226 albertel 1701: &mt('Unsupported character combination [_1] in filename, FAIL.',"<tt>'.$1.'</tt>").
1.296 raeburn 1702: '</span>';
1703: if ($usebuffer) {
1704: if (wantarray) {
1705: return ($output,0);
1706: } else {
1707: return 0;
1708: }
1709: } else {
1710: $r->print($output);
1711: return 0;
1712: }
1.196 www 1713: }
1714: unless ($target=~/\.(\w+)$/) {
1.296 raeburn 1715: $output = '<span class="LC_error">'.&mt('No valid extension found in filename, FAIL').'</span>';
1716: if ($usebuffer) {
1717: if (wantarray) {
1718: return ($output,0);
1719: } else {
1720: return 0;
1721: }
1722: } else {
1723: $r->print($output);
1724: return 0;
1725: }
1.196 www 1726: }
1727: if ($target=~/\.(\d+)\.(\w+)$/) {
1.296 raeburn 1728: $output = '<span class="LC_error">'.&mt('Filename of resource contains internal version number. Cannot publish such resources, FAIL').'</span>';
1729: if ($usebuffer) {
1730: if (wantarray) {
1731: return ($output,0);
1732: } else {
1733: return 0;
1734: }
1735: } else {
1736: $r->print($output);
1737: return 0;
1738: }
1.196 www 1739: }
1740: }
1.109 www 1741:
1.196 www 1742: #
1743: # End name check
1744: #
1.102 www 1745: $distarget=~s/\/+/\//g;
1.11 www 1746: my $logfile;
1747: unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
1.296 raeburn 1748: $output = '<span class="LC_error">'.
1749: &mt('No write permission to user directory, FAIL').'</span>';
1750: if ($usebuffer) {
1751: if (wantarray) {
1752: return ($output,0);
1753: } else {
1754: return 0;
1755: }
1756: } else {
1757: return 0;
1758: }
1.11 www 1759: }
1.227 albertel 1760:
1761: if ($source =~ /\.rights$/) {
1.296 raeburn 1762: $output = '<p><span class="LC_warning">'.&mt('Warning: It can take up to 1 hour for rights changes to fully propagate.').'</span></p>';
1763: unless ($usebuffer) {
1764: $r->print($output);
1765: $output = '';
1766: }
1.227 albertel 1767: }
1768:
1.11 www 1769: print $logfile
1.211 albertel 1770: "\n================= Publish ".localtime()." Phase Two ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n";
1.100 matthew 1771:
1772: %metadatafields=();
1773: %metadatakeys=();
1.167 albertel 1774:
1.209 www 1775: &metaeval(&unescape($env{'form.allmeta'}));
1.295 raeburn 1776:
1777: if ($batch) {
1778: my %commonaccess;
1779: map { $commonaccess{$_} = 1; } &Apache::loncommon::get_env_multiple('form.commonaccess');
1780: if ($commonaccess{'dist'}) {
1781: unless ($style eq 'prv') {
1782: if ($env{'form.commondistselect'} eq 'custom') {
1783: unless ($source =~ /\.rights$/) {
1784: if ($env{'form.commoncustomrights'} =~ m{^/res/.+\.rights$}) {
1785: $env{'form.customdistributionfile'} = $env{'form.commoncustomrights'};
1786: $env{'form.copyright'} = $env{'form.commondistselect'};
1787: }
1788: }
1789: } elsif ($env{'form.commondistselect'} =~ /^default|domain|public$/) {
1790: $env{'form.copyright'} = $env{'form.commondistselect'};
1791: }
1792: }
1793: }
1794: unless ($style eq 'prv') {
1795: if ($commonaccess{'source'}) {
1796: if (($env{'form.commonsourceselect'} eq 'open') || ($env{'form.commonsourceselect'} eq 'closed')) {
1797: $env{'form.sourceavail'} = $env{'form.commonsourceselect'};
1798: }
1799: }
1800: }
1801: }
1802:
1.192 albertel 1803: $metadatafields{'title'}=$env{'form.title'};
1804: $metadatafields{'author'}=$env{'form.author'};
1805: $metadatafields{'subject'}=$env{'form.subject'};
1806: $metadatafields{'notes'}=$env{'form.notes'};
1807: $metadatafields{'abstract'}=$env{'form.abstract'};
1808: $metadatafields{'mime'}=$env{'form.mime'};
1809: $metadatafields{'language'}=$env{'form.language'};
1810: $metadatafields{'creationdate'}=$env{'form.creationdate'};
1811: $metadatafields{'lastrevisiondate'}=$env{'form.lastrevisiondate'};
1812: $metadatafields{'owner'}=$env{'form.owner'};
1813: $metadatafields{'copyright'}=$env{'form.copyright'};
1814: $metadatafields{'standards'}=$env{'form.standards'};
1815: $metadatafields{'lowestgradelevel'}=$env{'form.lowestgradelevel'};
1816: $metadatafields{'highestgradelevel'}=$env{'form.highestgradelevel'};
1.115 www 1817: $metadatafields{'customdistributionfile'}=
1.192 albertel 1818: $env{'form.customdistributionfile'};
1819: $metadatafields{'sourceavail'}=$env{'form.sourceavail'};
1820: $metadatafields{'obsolete'}=$env{'form.obsolete'};
1.138 www 1821: $metadatafields{'obsoletereplacement'}=
1.192 albertel 1822: $env{'form.obsoletereplacement'};
1823: $metadatafields{'dependencies'}=$env{'form.dependencies'};
1.211 albertel 1824: $metadatafields{'modifyinguser'}=$env{'user.name'}.':'.
1.192 albertel 1825: $env{'user.domain'};
1.211 albertel 1826: $metadatafields{'authorspace'}=$cuname.':'.$cudom;
1.214 albertel 1827: $metadatafields{'domain'}=$cudom;
1.302 raeburn 1828:
1829: my $crsauthor;
1830: if ($env{'request.course.id'}) {
1831: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
1832: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
1833: if ($distarget =~ m{^/res/$cdom/$cnum}) {
1834: $crsauthor = 1;
1835: my $default_rights = "/res/$cdom/$cnum/default.rights";
1836: unless ($distarget eq $default_rights) {
1837: $metadatafields{'copyright'} = 'custom';
1838: $metadatafields{'customdistributionfile'} = $default_rights;
1839: }
1840: }
1841: }
1842:
1.192 albertel 1843: my $allkeywords=$env{'form.addkey'};
1844: if (exists($env{'form.keywords'})) {
1845: if (ref($env{'form.keywords'})) {
1846: $allkeywords .= ','.join(',',@{$env{'form.keywords'}});
1.100 matthew 1847: } else {
1.192 albertel 1848: $allkeywords .= ','.$env{'form.keywords'};
1.100 matthew 1849: }
1850: }
1.168 www 1851: $allkeywords=~s/[\"\']//g;
1.170 www 1852: $allkeywords=~s/\s*[\;\,]\s*/\,/g;
1.168 www 1853: $allkeywords=~s/\s+/ /g;
1854: $allkeywords=~s/^[ \,]//;
1855: $allkeywords=~s/[ \,]$//;
1.100 matthew 1856: $metadatafields{'keywords'}=$allkeywords;
1857:
1.149 www 1858: # check if custom distribution file is specified
1859: if ($metadatafields{'copyright'} eq 'custom') {
1860: my $file=$metadatafields{'customdistributionfile'};
1861: unless ($file=~/\.rights$/) {
1.296 raeburn 1862: $output .= '<span class="LC_error">'.&mt('No valid custom distribution rights file specified, FAIL').
1863: '</span>';
1864: if ($usebuffer) {
1865: if (wantarray) {
1866: return ($output,0);
1867: } else {
1868: return 0;
1869: }
1870: } else {
1871: $r->print($output);
1872: return 0;
1873: }
1.149 www 1874: }
1875: }
1.100 matthew 1876: {
1877: print $logfile "\nWrite metadata file for ".$source;
1878: my $mfh;
1879: unless ($mfh=Apache::File->new('>'.$source.'.meta')) {
1.296 raeburn 1880: $output .= '<span class="LC_error">'.&mt('Could not write metadata, FAIL').
1881: '</span>';
1882: if ($usebuffer) {
1883: if (wantarray) {
1884: return ($output,0);
1885: } else {
1886: return 0;
1887: }
1888: } else {
1889: $r->print($output);
1890: return 0;
1891: }
1.100 matthew 1892: }
1.294 raeburn 1893: foreach my $field (sort(keys(%metadatafields))) {
1894: unless ($field=~/\./) {
1895: my $unikey=$field;
1.100 matthew 1896: $unikey=~/^([A-Za-z]+)/;
1897: my $tag=$1;
1898: $tag=~tr/A-Z/a-z/;
1899: print $mfh "\n\<$tag";
1.294 raeburn 1900: foreach my $item (split(/\,/,$metadatakeys{$unikey})) {
1901: my $value=$metadatafields{$unikey.'.'.$item};
1.100 matthew 1902: $value=~s/\"/\'\'/g;
1.294 raeburn 1903: print $mfh ' '.$item.'="'.$value.'"';
1.100 matthew 1904: }
1905: print $mfh '>'.
1.165 albertel 1906: &HTML::Entities::encode($metadatafields{$unikey},'<>&"')
1.100 matthew 1907: .'</'.$tag.'>';
1908: }
1909: }
1.296 raeburn 1910:
1911: $output .= '<p>'.&mt('Wrote Metadata').'</p>';
1912: unless ($usebuffer) {
1913: $r->print($output);
1914: $output = '';
1915: }
1.100 matthew 1916: print $logfile "\nWrote metadata";
1917: }
1918:
1919: # -------------------------------- Synchronize entry with SQL metadata database
1.12 www 1920:
1.89 matthew 1921: $metadatafields{'url'} = $distarget;
1922: $metadatafields{'version'} = 'current';
1.152 www 1923:
1.297 raeburn 1924: unless ($crsauthor) {
1925: my ($error,$success) = &store_metadata(%metadatafields);
1926: if ($success) {
1927: $output .= '<p>'.&mt('Synchronized SQL metadata database').'</p>';
1928: print $logfile "\nSynchronized SQL metadata database";
1929: } else {
1930: $output .= $error;
1931: print $logfile "\n".$error;
1932: }
1933: unless ($usebuffer) {
1934: $r->print($output);
1935: $output = '';
1936: }
1.296 raeburn 1937: }
1.159 www 1938: # --------------------------------------------- Delete author resource messages
1939: my $delresult=&Apache::lonmsg::del_url_author_res_msg($target);
1.296 raeburn 1940: $output .= '<p>'.&mt('Removing error messages:').' '.$delresult.'</p>';
1941: unless ($usebuffer) {
1942: $r->print($output);
1943: $output = '';
1944: }
1.159 www 1945: print $logfile "\nRemoving error messages: $delresult";
1.12 www 1946: # ----------------------------------------------------------- Copy old versions
1947:
1.100 matthew 1948: if (-e $target) {
1949: my $filename;
1950: my $maxversion=0;
1951: $target=~/(.*)\/([^\/]+)\.(\w+)$/;
1952: my $srcf=$2;
1953: my $srct=$3;
1954: my $srcd=$1;
1.261 raeburn 1955: my $docroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1956: unless ($srcd=~/^\Q$docroot\E\/res/) {
1.100 matthew 1957: print $logfile "\nPANIC: Target dir is ".$srcd;
1.296 raeburn 1958: $output .=
1959: "<span class=\"LC_error\">".&mt('Invalid target directory, FAIL')."</span>";
1960: if ($usebuffer) {
1961: if (wantarray) {
1962: return ($output,0);
1963: } else {
1964: return 0;
1965: }
1966: } else {
1967: $r->print($output);
1968: return 0;
1969: }
1.100 matthew 1970: }
1971: opendir(DIR,$srcd);
1972: while ($filename=readdir(DIR)) {
1973: if (-l $srcd.'/'.$filename) {
1974: unlink($srcd.'/'.$filename);
1975: unlink($srcd.'/'.$filename.'.meta');
1976: } else {
1.252 raeburn 1977: if ($filename=~/^\Q$srcf\E\.(\d+)\.\Q$srct\E$/) {
1.100 matthew 1978: $maxversion=($1>$maxversion)?$1:$maxversion;
1979: }
1980: }
1981: }
1982: closedir(DIR);
1983: $maxversion++;
1.296 raeburn 1984: $output .= '<p>'.&mt('Creating old version [_1]',$maxversion).'</p>';
1985: unless ($usebuffer) {
1986: $r->print($output);
1987: $output = '';
1988: }
1.125 www 1989: print $logfile "\nCreating old version ".$maxversion."\n";
1.100 matthew 1990:
1991: my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct;
1992:
1.13 www 1993: if (copy($target,$copyfile)) {
1.12 www 1994: print $logfile "Copied old target to ".$copyfile."\n";
1.296 raeburn 1995: $output .= &Apache::lonhtmlcommon::confirm_success(&mt('Copied old target file'));
1996: unless ($usebuffer) {
1997: $r->print($output);
1998: $output = '';
1999: }
1.12 www 2000: } else {
1.13 www 2001: print $logfile "Unable to write ".$copyfile.':'.$!."\n";
1.296 raeburn 2002: $output .= &Apache::lonhtmlcommon::confirm_success(&mt('Failed to copy old target').", $!",1);
2003: if ($usebuffer) {
2004: if (wantarray) {
2005: return ($output,0);
2006: } else {
2007: return 0;
2008: }
2009: } else {
2010: $r->print($output);
2011: return 0;
2012: }
1.12 www 2013: }
1.100 matthew 2014:
1.12 www 2015: # --------------------------------------------------------------- Copy Metadata
2016:
2017: $copyfile=$copyfile.'.meta';
1.100 matthew 2018:
1.13 www 2019: if (copy($target.'.meta',$copyfile)) {
1.14 www 2020: print $logfile "Copied old target metadata to ".$copyfile."\n";
1.296 raeburn 2021: $output .= &Apache::lonhtmlcommon::confirm_success(&mt('Copied old metadata'));
2022: unless ($usebuffer) {
2023: $r->print($output);
2024: $output = '';
2025: }
1.12 www 2026: } else {
1.13 www 2027: print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n";
1.14 www 2028: if (-e $target.'.meta') {
1.296 raeburn 2029: $output .= &Apache::lonhtmlcommon::confirm_success(
2030: &mt('Failed to write old metadata copy').", $!",1);
2031: if ($usebuffer) {
2032: if (wantarray) {
2033: return ($output,0);
2034: } else {
2035: return 0;
2036: }
2037: } else {
2038: $r->print($output);
2039: return 0;
2040: }
1.14 www 2041: }
1.12 www 2042: }
1.100 matthew 2043: } else {
1.296 raeburn 2044: $output .= '<p>'.&mt('Initial version').'</p>';
2045: unless ($usebuffer) {
2046: $r->print($output);
2047: $output = '';
2048: }
1.100 matthew 2049: print $logfile "\nInitial version";
2050: }
1.12 www 2051:
2052: # ---------------------------------------------------------------- Write Source
1.100 matthew 2053: my $copyfile=$target;
2054:
2055: my @parts=split(/\//,$copyfile);
2056: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
2057:
2058: my $count;
2059: for ($count=5;$count<$#parts;$count++) {
2060: $path.="/$parts[$count]";
2061: if ((-e $path)!=1) {
2062: print $logfile "\nCreating directory ".$path;
2063: mkdir($path,0777);
1.296 raeburn 2064: $output .= '<p>'
2065: .&mt('Created directory [_1]'
2066: ,'<span class="LC_filename">'.$parts[$count].'</span>')
2067: .'</p>';
2068: unless ($usebuffer) {
2069: $r->print($output);
2070: $output = '';
2071: }
1.12 www 2072: }
1.100 matthew 2073: }
2074:
2075: if (copy($source,$copyfile)) {
2076: print $logfile "\nCopied original source to ".$copyfile."\n";
1.296 raeburn 2077: $output .= &Apache::lonhtmlcommon::confirm_success(&mt('Copied source file'));
2078: unless ($usebuffer) {
2079: $r->print($output);
2080: $output = '';
2081: }
1.100 matthew 2082: } else {
2083: print $logfile "\nUnable to write ".$copyfile.':'.$!."\n";
1.296 raeburn 2084: $output .= &Apache::lonhtmlcommon::confirm_success(
2085: &mt('Failed to copy source').", $!",1);
2086: if ($usebuffer) {
2087: if (wantarray) {
2088: return ($output,0);
2089: } else {
2090: return 0;
2091: }
2092: } else {
2093: $r->print($output);
2094: return 0;
2095: }
1.100 matthew 2096: }
2097:
1.265 www 2098: # ---------------------------------------------- Delete local tmp-preview files
2099: unlink($copyfile.'.tmp');
1.12 www 2100: # --------------------------------------------------------------- Copy Metadata
2101:
1.100 matthew 2102: $copyfile=$copyfile.'.meta';
2103:
2104: if (copy($source.'.meta',$copyfile)) {
2105: print $logfile "\nCopied original metadata to ".$copyfile."\n";
1.296 raeburn 2106: $output .= &Apache::lonhtmlcommon::confirm_success(&mt('Copied metadata'));
2107: unless ($usebuffer) {
2108: $r->print($output);
2109: $output = '';
2110: }
1.100 matthew 2111: } else {
2112: print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n";
1.296 raeburn 2113: $output .= &Apache::lonhtmlcommon::confirm_success(
2114: &mt('Failed to write metadata copy').", $!",1);
2115: if ($usebuffer) {
2116: if (wantarray) {
2117: return ($output,0);
2118: } else {
2119: return 0;
2120: }
2121: } else {
2122: $r->print($output);
2123: return 0;
2124: }
2125: }
2126: unless ($usebuffer) {
2127: $r->rflush;
1.100 matthew 2128: }
1.12 www 2129:
1.181 www 2130: # ------------------------------------------------------------- Trigger updates
1.183 www 2131: push(@{$modified_urls},[$target,$source]);
1.304 ! raeburn 2132: ¬ify_in_cleanup($r);
1.199 www 2133:
2134: # ---------------------------------------------------------- Clear local caches
2135: my $thisdistarget=$target;
2136: $thisdistarget=~s/^\Q$docroot\E//;
2137: &Apache::lonnet::devalidate_cache_new('resversion',$target);
2138: &Apache::lonnet::devalidate_cache_new('meta',
2139: &Apache::lonnet::declutter($thisdistarget));
2140:
1.255 bisitz 2141: # ------------------------------------------------------------- Everything done
2142: $logfile->close();
1.296 raeburn 2143: $output .= '<p class="LC_success">'.&mt('Done').'</p>';
2144: unless ($usebuffer) {
2145: $r->print($output);
2146: $output = '';
2147: }
1.255 bisitz 2148:
1.12 www 2149: # ------------------------------------------------ Provide link to new resource
1.100 matthew 2150: unless ($batch) {
2151:
1.271 www 2152: my $thissrc=&Apache::loncfile::url($source);
1.100 matthew 2153: my $thissrcdir=$thissrc;
2154: $thissrcdir=~s/\/[^\/]+$/\//;
2155:
1.296 raeburn 2156: $output .=
1.284 bisitz 2157: &Apache::lonhtmlcommon::actionbox([
1.264 raeburn 2158: '<a href="'.$thisdistarget.'">'.
2159: &mt('View Published Version').
1.284 bisitz 2160: '</a>',
1.264 raeburn 2161: '<a href="'.$thissrc.'">'.
2162: &mt('Back to Source').
1.284 bisitz 2163: '</a>',
1.264 raeburn 2164: '<a href="'.$thissrcdir.'">'.
2165: &mt('Back to Source Directory').
1.296 raeburn 2166: '</a>']);
2167: unless ($usebuffer) {
2168: $r->print($output);
2169: $output = '';
2170: }
2171: }
2172:
2173: if ($usebuffer) {
2174: if (wantarray) {
2175: return ($output,1);
2176: } else {
2177: return 1;
2178: }
2179: } else {
2180: if (wantarray) {
2181: return ('',1);
2182: } else {
2183: return 1;
2184: }
1.100 matthew 2185: }
1.11 www 2186: }
2187:
1.304 ! raeburn 2188: sub notify_in_cleanup {
! 2189: my ($r) = @_;
! 2190: unless ($registered_cleanup) {
! 2191: my $handlers = $r->get_handlers('PerlCleanupHandler');
! 2192: $r->set_handlers('PerlCleanupHandler' => [\¬ify,@{$handlers}]);
! 2193: $registered_cleanup=1;
! 2194: }
! 2195: }
! 2196:
1.181 www 2197: # =============================================================== Notifications
2198: sub notify {
2199: # --------------------------------------------------- Send update notifications
1.183 www 2200: foreach my $targetsource (@{$modified_urls}){
1.182 www 2201: my ($target,$source)=@{$targetsource};
2202: my $logfile=Apache::File->new('>>'.$source.'.log');
2203: print $logfile "\nCleanup phase: Notifications\n";
2204: my @subscribed=&get_subscribed_hosts($target);
2205: foreach my $subhost (@subscribed) {
2206: print $logfile "\nNotifying host ".$subhost.':';
2207: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);
2208: print $logfile $reply;
2209: }
1.181 www 2210: # ---------------------------------------- Send update notifications, meta only
1.182 www 2211: my @subscribedmeta=&get_subscribed_hosts("$target.meta");
2212: foreach my $subhost (@subscribedmeta) {
2213: print $logfile "\nNotifying host for metadata only ".$subhost.':';
2214: my $reply=&Apache::lonnet::critical('update:'.$target.'.meta',
2215: $subhost);
2216: print $logfile $reply;
2217: }
1.181 www 2218: # --------------------------------------------------- Notify subscribed courses
1.182 www 2219: my %courses=&coursedependencies($target);
2220: my $now=time;
1.294 raeburn 2221: foreach my $course (keys(%courses)) {
2222: print $logfile "\nNotifying course ".$course.':';
2223: my ($cdom,$cname)=split(/\_/,$course);
1.182 www 2224: my $reply=&Apache::lonnet::cput
2225: ('versionupdate',{$target => $now},$cdom,$cname);
2226: print $logfile $reply;
2227: }
2228: print $logfile "\n============ Done ============\n";
2229: $logfile->close();
1.181 www 2230: }
1.233 www 2231: if ($lock) { &Apache::lonnet::remove_lock($lock); }
1.182 www 2232: return OK;
1.181 www 2233: }
2234:
1.95 www 2235: #########################################
2236:
2237: sub batchpublish {
1.296 raeburn 2238: my ($r,$srcfile,$targetfile,$nokeyref,$usebuffer)=@_;
1.192 albertel 2239: #publication pollutes %env with form.* values
2240: my %oldenv=%env;
1.102 www 2241: $srcfile=~s/\/+/\//g;
2242: $targetfile=~s/\/+/\//g;
1.96 www 2243:
1.97 www 2244: my $docroot=$r->dir_config('lonDocRoot');
2245: my $thisdistarget=$targetfile;
1.122 albertel 2246: $thisdistarget=~s/^\Q$docroot\E//;
1.97 www 2247:
1.96 www 2248:
1.139 albertel 2249: %metadatafields=();
2250: %metadatakeys=();
2251: $srcfile=~/\.(\w+)$/;
2252: my $thistype=$1;
1.97 www 2253:
2254:
1.139 albertel 2255: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
1.96 www 2256:
1.296 raeburn 2257: my $output = '<h2>'
1.271 www 2258: .&mt('Publishing [_1]',&Apache::loncfile::display($srcfile))
1.296 raeburn 2259: .'</h2>';
2260: unless ($usebuffer) {
2261: $r->print($output);
2262: $output = '';
2263: }
1.97 www 2264:
2265: # phase one takes
2266: # my ($source,$target,$style,$batch)=@_;
1.296 raeburn 2267: my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1,$nokeyref);
2268:
2269: if ($usebuffer) {
2270: $output .= '<p>'.$outstring.'</p>';
2271: } else {
2272: $r->print('<p>'.$outstring.'</p>');
2273: }
1.96 www 2274: # phase two takes
2275: # my ($source,$target,$style,$distarget,batch)=@_;
1.192 albertel 2276: # $env{'form.allmeta'},$env{'form.title'},$env{'form.author'},...
1.113 albertel 2277: if (!$error) {
1.296 raeburn 2278: if ($usebuffer) {
2279: my ($result,$error) = &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1,$usebuffer);
2280: $output .= '<p>'.$result.'</p>';
2281: } else {
2282: &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1);
2283: }
1.113 albertel 2284: }
1.192 albertel 2285: %env=%oldenv;
1.296 raeburn 2286: if ($usebuffer) {
2287: return $output;
2288: } else {
2289: return '';
2290: }
1.95 www 2291: }
1.1 www 2292:
1.90 matthew 2293: #########################################
1.95 www 2294:
2295: sub publishdirectory {
1.303 raeburn 2296: my ($r,$fn,$thisdisfn,$nokeyref,$crsauthor)=@_;
1.102 www 2297: $fn=~s/\/+/\//g;
2298: $thisdisfn=~s/\/+/\//g;
1.273 www 2299: my $thisdisresdir=$thisdisfn;
2300: $thisdisresdir=~s/^\/priv\//\/res\//;
1.276 raeburn 2301: my $resdir = $r->dir_config('lonDocRoot').$thisdisresdir;
1.289 bisitz 2302: $r->print('<form name="pubdirpref" method="post" action="">'
2303: .&Apache::lonhtmlcommon::start_pick_box()
1.258 bisitz 2304: .&Apache::lonhtmlcommon::row_title(&mt('Directory'))
2305: .'<span class="LC_filename">'.$thisdisfn.'</span>'
2306: .&Apache::lonhtmlcommon::row_closure()
2307: .&Apache::lonhtmlcommon::row_title(&mt('Target'))
1.273 www 2308: .'<span class="LC_filename">'.$thisdisresdir.'</span>'
1.258 bisitz 2309: );
1.299 raeburn 2310: my %reasons = &Apache::lonlocal::texthash(
2311: mod => 'Authoring Space file postdates published file',
2312: modmeta => 'Authoring Space metadata file postdates published file',
2313: unpub => 'Resource is unpublished',
2314: );
1.139 albertel 2315:
2316: my $dirptr=16384; # Mask indicating a directory in stat.cmode.
1.193 www 2317: unless ($env{'form.phase'} eq 'two') {
2318: # ask user what they want
1.258 bisitz 2319: $r->print(&Apache::lonhtmlcommon::row_closure()
1.299 raeburn 2320: .&Apache::lonhtmlcommon::row_title(&mt('Options')
2321: .&Apache::loncommon::help_open_topic('Publishing_Directory_Options')));
1.289 bisitz 2322: $r->print(&hiddenfield('phase','two').
1.193 www 2323: &hiddenfield('filename',$env{'form.filename'}).
1.299 raeburn 2324: '<fieldset><legend>'.&mt('Recurse').'</legend>'.
2325: &checkbox('pubrec','include subdirectories').
2326: '</fieldset>'.
2327: '<fieldset><legend>'.&mt('Force').'</legend>'.
2328: &checkbox('forcerepub','force republication of previously published files').'<br />'.
2329: &checkbox('forceoverride','force directory level metadata over existing').
2330: '</fieldset>'.
2331: '<fieldset><legend>'.&mt('Exclude').'</legend>'.
2332: &checkbox('excludeunpub','exclude currently unpublished files').'<br />'.
2333: &checkbox('excludemod','exclude modified files').'<br />'.
2334: &checkbox('excludemodmeta','exclude files with modified metadata').
2335: '</fieldset>'.
2336: '<fieldset><legend>'.&mt('Actions').'</legend>'.
1.303 raeburn 2337: &checkbox('obsolete','make file(s) obsolete').'<br />');
2338: unless ($crsauthor) {
2339: $r->print(&common_access('dist',&mt('apply common copyright/distribution'),
2340: ['default','domain','public','custom']).'<br />');
2341: }
2342: $r->print(&common_access('source',&mt('apply common source availability'),
1.299 raeburn 2343: ['closed','open']).
2344: '</fieldset>'
1.289 bisitz 2345: );
1.258 bisitz 2346: $r->print(&Apache::lonhtmlcommon::row_closure(1)
2347: .&Apache::lonhtmlcommon::end_pick_box()
1.289 bisitz 2348: .'<br /><input type="submit" value="'.&mt('Publish Directory').'" /></form>'
1.258 bisitz 2349: );
1.233 www 2350: $lock=0;
1.193 www 2351: } else {
1.258 bisitz 2352: $r->print(&Apache::lonhtmlcommon::row_closure(1)
2353: .&Apache::lonhtmlcommon::end_pick_box()
2354: );
1.299 raeburn 2355: my %commonaccess;
2356: map { $commonaccess{$_} = 1; } &Apache::loncommon::get_env_multiple('form.commonaccess');
1.234 www 2357: unless ($lock) { $lock=&Apache::lonnet::set_lock(&mt('Publishing [_1]',$fn)); }
1.304 ! raeburn 2358: if ($lock) {
! 2359: ¬ify_in_cleanup($r);
! 2360: }
1.193 www 2361: # actually publish things
2362: opendir(DIR,$fn);
2363: my @files=sort(readdir(DIR));
2364: foreach my $filename (@files) {
2365: my ($cdev,$cino,$cmode,$cnlink,
2366: $cuid,$cgid,$crdev,$csize,
2367: $catime,$cmtime,$cctime,
2368: $cblksize,$cblocks)=stat($fn.'/'.$filename);
1.304 ! raeburn 2369:
1.193 www 2370: my $extension='';
2371: if ($filename=~/\.(\w+)$/) { $extension=$1; }
2372: if ($cmode&$dirptr) {
2373: if (($filename!~/^\./) && ($env{'form.pubrec'})) {
1.303 raeburn 2374: &publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename,$nokeyref,$crsauthor);
1.193 www 2375: }
2376: } elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') &&
2377: ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) {
1.298 raeburn 2378: # find out publication status and/or existing metadata
1.193 www 2379: my $publishthis=0;
1.299 raeburn 2380: my $skipthis;
1.193 www 2381: if (-e $resdir.'/'.$filename) {
2382: my ($rdev,$rino,$rmode,$rnlink,
2383: $ruid,$rgid,$rrdev,$rsize,
2384: $ratime,$rmtime,$rctime,
2385: $rblksize,$rblocks)=stat($resdir.'/'.$filename);
2386: if (($rmtime<$cmtime) || ($env{'form.forcerepub'})) {
1.96 www 2387: # previously published, modified now
1.299 raeburn 2388: if ($env{'form.excludemod'}) {
2389: $skipthis='mod';
2390: } else {
2391: $publishthis=1;
2392: }
1.212 albertel 2393: }
1.299 raeburn 2394: unless ($skipthis) {
2395: my $meta_cmtime = (stat($fn.'/'.$filename.'.meta'))[9];
2396: my $meta_rmtime = (stat($resdir.'/'.$filename.'.meta'))[9];
2397: if ( $meta_rmtime<$meta_cmtime ) {
2398: if ($env{'form.excludemodmeta'}) {
2399: $skipthis='modmeta';
2400: $publishthis=0;
2401: } else {
2402: $publishthis=1;
2403: }
2404: } else {
2405: unless (&Apache::loncommon::fileembstyle($extension) eq 'prv') {
2406: if ($commonaccess{'dist'}) {
2407: my ($currdist,$currdistfile,$currsourceavail);
2408: my $currdist = &Apache::lonnet::metadata($thisdisresdir.'/'.$filename,'copyright');
2409: if ($currdist eq 'custom') {
2410: $currdistfile = &Apache::lonnet::metadata($thisdisresdir.'/'.$filename,'customdistributionfile');
2411: }
2412: if ($env{'form.commondistselect'} eq 'custom') {
2413: if ($env{'form.commoncustomrights'} =~ m{^/res/.+\.rights$}) {
2414: if ($currdist eq 'custom') {
2415: unless ($env{'form.commoncustomrights'} eq $currdistfile) {
2416: $publishthis=1;
2417: }
2418: } else {
2419: $publishthis=1;
2420: }
2421: }
2422: } elsif ($env{'form.commondistselect'} =~ /^default|domain|public$/) {
2423: unless ($currdist eq $env{'form.commondistselect'}) {
2424: $publishthis=1;
2425: }
2426: }
2427: }
2428: }
2429: }
2430: }
1.193 www 2431: } else {
2432: # never published
1.299 raeburn 2433: if ($env{'form.excludeunpub'}) {
2434: $skipthis='unpub';
2435: } else {
2436: $publishthis=1;
2437: }
1.193 www 2438: }
1.212 albertel 2439:
1.193 www 2440: if ($publishthis) {
1.296 raeburn 2441: &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename,$nokeyref);
1.193 www 2442: } else {
1.299 raeburn 2443: my $reason;
2444: if ($skipthis) {
2445: $reason = $reasons{$skipthis};
2446: } else {
2447: $reason = &mt('No changes needed to published resource or metadata');
2448: }
2449: $r->print('<br />'.&mt('Skipping').' '.$filename);
2450: if ($reason) {
2451: $r->print(' ('.$reason.')');
2452: }
2453: $r->print('<br />');
1.193 www 2454: }
2455: $r->rflush();
1.139 albertel 2456: }
2457: }
1.193 www 2458: closedir(DIR);
1.139 albertel 2459: }
1.95 www 2460: }
1.160 www 2461:
2462: #########################################
2463: # publish a default.meta file
2464:
2465: sub defaultmetapublish {
2466: my ($r,$fn,$cuname,$cudom)=@_;
2467: unless (-e $fn) {
2468: return HTTP_NOT_FOUND;
2469: }
2470: my $target=$fn;
1.270 www 2471: $target=~s/^\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/priv\//\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/res\//;
1.160 www 2472:
2473:
2474: &Apache::loncommon::content_type($r,'text/html');
2475: $r->send_http_header;
2476:
1.251 schafran 2477: $r->print(&Apache::loncommon::start_page('Metadata Publication'));
1.160 www 2478:
2479: # ---------------------------------------------------------------- Write Source
2480: my $copyfile=$target;
2481:
2482: my @parts=split(/\//,$copyfile);
2483: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
2484:
2485: my $count;
2486: for ($count=5;$count<$#parts;$count++) {
2487: $path.="/$parts[$count]";
2488: if ((-e $path)!=1) {
2489: mkdir($path,0777);
1.255 bisitz 2490: $r->print('<p>'
2491: .&mt('Created directory [_1]'
2492: ,'<span class="LC_filename">'.$parts[$count].'</span>')
2493: .'</p>'
2494: );
1.160 www 2495: }
2496: }
2497:
2498: if (copy($fn,$copyfile)) {
2499: $r->print('<p>'.&mt('Copied source file').'</p>');
2500: } else {
1.226 albertel 2501: return "<span class=\"LC_error\">".
2502: &mt('Failed to copy source').", $!, ".&mt('FAIL')."</span>";
1.160 www 2503: }
2504:
2505: # --------------------------------------------------- Send update notifications
2506:
2507: my @subscribed=&get_subscribed_hosts($target);
2508: foreach my $subhost (@subscribed) {
2509: $r->print('<p>'.&mt('Notifying host').' '.$subhost.':');$r->rflush;
2510: my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);
2511: $r->print($reply.'</p><br />');$r->rflush;
2512: }
2513: # ------------------------------------------------------------------- Link back
1.281 raeburn 2514: $r->print("<a href='".&Apache::loncfile::display($fn)."'>".&mt('Back to Metadata').'</a>');
1.208 albertel 2515: $r->print(&Apache::loncommon::end_page());
1.160 www 2516: return OK;
2517: }
1.90 matthew 2518: #########################################
2519:
2520: =pod
2521:
1.94 harris41 2522: =item B<handler>
1.90 matthew 2523:
2524: A basic outline of the handler subroutine follows.
2525:
2526: =over 4
2527:
1.94 harris41 2528: =item *
2529:
2530: Get query string for limited number of parameters.
2531:
2532: =item *
2533:
2534: Check filename.
2535:
2536: =item *
2537:
2538: File is there and owned, init lookup tables.
2539:
2540: =item *
1.90 matthew 2541:
1.94 harris41 2542: Start page output.
1.90 matthew 2543:
1.94 harris41 2544: =item *
1.90 matthew 2545:
1.94 harris41 2546: Evaluate individual file, and then output information.
1.90 matthew 2547:
1.94 harris41 2548: =item *
1.90 matthew 2549:
1.94 harris41 2550: Publishing from $thisfn to $thistarget with $thisembstyle.
1.90 matthew 2551:
2552: =back
2553:
2554: =cut
2555:
2556: #########################################
2557: #########################################
1.1 www 2558: sub handler {
1.139 albertel 2559: my $r=shift;
1.2 www 2560:
1.139 albertel 2561: if ($r->header_only) {
2562: &Apache::loncommon::content_type($r,'text/html');
2563: $r->send_http_header;
2564: return OK;
2565: }
1.2 www 2566:
1.43 www 2567: # Get query string for limited number of parameters
2568:
1.80 matthew 2569: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
2570: ['filename']);
1.43 www 2571:
1.183 www 2572: # -------------------------------------- Flag and buffer for registered cleanup
1.182 www 2573: $registered_cleanup=0;
1.183 www 2574: @{$modified_urls}=();
1.2 www 2575: # -------------------------------------------------------------- Check filename
2576:
1.209 www 2577: my $fn=&unescape($env{'form.filename'});
1.280 raeburn 2578: ($cuname,$cudom)=&Apache::lonnet::constructaccess($fn);
1.268 www 2579: # ----------------------------------------------------- Do we have permissions?
2580: unless (($cuname) && ($cudom)) {
2581: $r->log_reason($env{'user.name'}.' at '.$env{'user.domain'}.
2582: ' trying to publish file '.$env{'form.filename'}.
2583: ' - not authorized',
2584: $r->filename);
2585: return HTTP_NOT_ACCEPTABLE;
2586: }
2587: # ----------------------------------------------------------------- Get docroot
2588: $docroot=$r->dir_config('lonDocRoot');
1.160 www 2589:
2590:
2591: # special publication: default.meta file
2592: if ($fn=~/\/default.meta$/) {
2593: return &defaultmetapublish($r,$fn,$cuname,$cudom);
2594: }
1.159 www 2595: $fn=~s/\.meta$//;
1.268 www 2596:
2597: # sanity test on the filename
2598:
1.139 albertel 2599: unless ($fn) {
2600: $r->log_reason($cuname.' at '.$cudom.
2601: ' trying to publish empty filename', $r->filename);
2602: return HTTP_NOT_FOUND;
2603: }
2604:
1.268 www 2605: unless (-e $docroot.$fn) {
1.139 albertel 2606: $r->log_reason($cuname.' at '.$cudom.
2607: ' trying to publish non-existing file '.
1.192 albertel 2608: $env{'form.filename'}.' ('.$fn.')',
1.139 albertel 2609: $r->filename);
2610: return HTTP_NOT_FOUND;
2611: }
1.2 www 2612:
1.296 raeburn 2613: # --------------------------------- File is there and owned, start page output
1.2 www 2614:
1.139 albertel 2615: &Apache::loncommon::content_type($r,'text/html');
2616: $r->send_http_header;
1.302 raeburn 2617:
1.259 bisitz 2618: # Breadcrumbs
2619: &Apache::lonhtmlcommon::clear_breadcrumbs();
1.302 raeburn 2620: my $crumbtext = 'Authoring Space';
2621: my $crumbhref = &Apache::loncommon::authorspace($fn);
1.303 raeburn 2622: my $crsauthor;
1.302 raeburn 2623: if ($env{'request.course.id'}) {
2624: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
2625: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
2626: if ($crumbhref eq "/priv/$cdom/$cnum/") {
2627: $crumbtext = 'Course Authoring Space';
1.303 raeburn 2628: $crsauthor = 1;
1.302 raeburn 2629: }
2630: }
1.259 bisitz 2631: &Apache::lonhtmlcommon::add_breadcrumb({
1.302 raeburn 2632: 'text' => $crumbtext,
2633: 'href' => $crumbhref,
1.259 bisitz 2634: });
2635: &Apache::lonhtmlcommon::add_breadcrumb({
2636: 'text' => 'Resource Publication',
2637: 'href' => '',
2638: });
2639:
1.208 albertel 2640: my $js='<script type="text/javascript">'.
2641: &Apache::loncommon::browser_and_searcher_javascript().
2642: '</script>';
1.295 raeburn 2643: my $startargs = {};
2644: if ($fn=~/\/$/) {
2645: unless ($env{'form.phase'} eq 'two') {
2646: $startargs->{'add_entries'} = { onload => 'javascript:setDefaultAccess();' };
2647: $js .= <<"END";
2648: <script type="text/javascript">
2649: // <![CDATA[
2650: function showHideAccess(caller,div) {
2651: if (document.getElementById(div)) {
2652: if (caller.checked) {
2653: document.getElementById(div).style.display='inline-block';
2654: } else {
2655: document.getElementById(div).style.display='none';
2656: }
2657: }
2658: }
2659:
2660: function showHideCustom(caller,divid) {
2661: if (document.getElementById(divid)) {
2662: if (caller.options[caller.selectedIndex].value == 'custom') {
2663: document.getElementById(divid).style.display="inline-block";
2664: } else {
2665: document.getElementById(divid).style.display="none";
2666: }
2667: }
2668: }
2669: function setDefaultAccess() {
2670: var chkids = Array('LC_commondist','LC_commonsource');
2671: for (var i=0; i<chkids.length; i++) {
2672: if (document.getElementById(chkids[i])) {
2673: document.getElementById(chkids[i]).checked = false;
2674: }
2675: if (document.getElementById(chkids[i]+'select')) {
2676: document.getElementById(chkids[i]+'select').selectedIndex = 0;
2677: }
2678: if (document.getElementById(chkids[i]+'div')) {
2679: document.getElementById(chkids[i]+'div').style.display = 'none';
2680: }
2681: }
2682: }
2683: // ]]>
2684: </script>
2685:
2686: END
2687: }
2688: }
2689: $r->print(&Apache::loncommon::start_page('Resource Publication',$js,$startargs)
1.259 bisitz 2690: .&Apache::lonhtmlcommon::breadcrumbs()
2691: .&Apache::loncommon::head_subbox(
1.275 raeburn 2692: &Apache::loncommon::CSTR_pageheader($docroot.$fn))
1.259 bisitz 2693: );
1.101 www 2694:
1.268 www 2695: my $thisdisfn=&HTML::Entities::encode($fn,'<>&"');
2696: my $thistarget=$fn;
2697: $thistarget=~s/^\/priv\//\/res\//;
2698: my $thisdistarget=&HTML::Entities::encode($thistarget,'<>&"');
1.296 raeburn 2699: my $nokeyref = &getnokey($r->dir_config('lonIncludes'));
1.95 www 2700:
1.139 albertel 2701: if ($fn=~/\/$/) {
1.95 www 2702: # -------------------------------------------------------- This is a directory
1.303 raeburn 2703: &publishdirectory($r,$docroot.$fn,$thisdisfn,$nokeyref,$crsauthor);
1.289 bisitz 2704: $r->print(
2705: '<br /><br />'.
2706: &Apache::lonhtmlcommon::actionbox([
2707: '<a href="'.$thisdisfn.'">'.&mt('Return to Directory').'</a>']));
1.139 albertel 2708: } else {
1.94 harris41 2709: # ---------------------- Evaluate individual file, and then output information.
1.268 www 2710: $fn=~/\.(\w+)$/;
1.139 albertel 2711: my $thistype=$1;
2712: my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
1.200 raeburn 2713: if ($thistype eq 'page') { $thisembstyle = 'rat'; }
1.2 www 2714:
1.254 bisitz 2715: $r->print('<h2>'
2716: .&mt('Publishing [_1]'
2717: ,'<span class="LC_filename">'.$thisdisfn.'</span>')
2718: .'</h2>'
2719: );
1.239 bisitz 2720:
2721: $r->print('<h3>'.&mt('Resource Details').'</h3>');
2722:
2723: $r->print(&Apache::lonhtmlcommon::start_pick_box());
2724:
2725: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Type'))
2726: .&Apache::loncommon::filedescription($thistype)
2727: .&Apache::lonhtmlcommon::row_closure()
2728: );
2729:
2730: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Link to Resource'))
2731: .'<tt>'
2732: );
1.139 albertel 2733: $r->print(<<ENDCAPTION);
1.268 www 2734: <a href='javascript:void(window.open("$thisdisfn","cat","height=300,width=500,scrollbars=1,resizable=1,menubar=0,location=1"))'>
1.129 www 2735: $thisdisfn</a>
2736: ENDCAPTION
1.239 bisitz 2737: $r->print('</tt>'
2738: .&Apache::lonhtmlcommon::row_closure()
2739: );
2740:
2741: $r->print(&Apache::lonhtmlcommon::row_title(&mt('Target'))
2742: .'<tt>'.$thisdistarget.'</tt>'
2743: );
1.192 albertel 2744: if (($cuname ne $env{'user.name'})||($cudom ne $env{'user.domain'})) {
1.240 raeburn 2745: $r->print(&Apache::lonhtmlcommon::row_closure()
2746: .&Apache::lonhtmlcommon::row_title(&mt('Co-Author'))
1.239 bisitz 2747: .'<span class="LC_warning">'
1.258 bisitz 2748: .&Apache::loncommon::plainname($cuname,$cudom) .' ('.$cuname.':'.$cudom.')'
1.239 bisitz 2749: .'</span>'
2750: );
1.139 albertel 2751: }
1.26 www 2752:
1.139 albertel 2753: if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') {
1.240 raeburn 2754: $r->print(&Apache::lonhtmlcommon::row_closure()
2755: .&Apache::lonhtmlcommon::row_title(&mt('Diffs')));
1.139 albertel 2756: $r->print(<<ENDDIFF);
1.284 bisitz 2757: <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"))'>
1.129 www 2758: ENDDIFF
1.240 raeburn 2759: $r->print(&mt('Diffs with Current Version').'</a>');
1.139 albertel 2760: }
1.240 raeburn 2761:
2762: $r->print(&Apache::lonhtmlcommon::row_closure(1)
2763: .&Apache::lonhtmlcommon::end_pick_box()
2764: );
1.11 www 2765:
1.268 www 2766: # ---------------------- Publishing from $fn to $thistarget with $thisembstyle.
1.2 www 2767:
1.192 albertel 2768: unless ($env{'form.phase'} eq 'two') {
1.185 www 2769: # ---------------------------------------------------------- Parse for problems
1.189 albertel 2770: my ($warningcount,$errorcount);
2771: if ($thisembstyle eq 'ssi') {
1.268 www 2772: ($warningcount,$errorcount)=&checkonthis($r,$fn);
1.189 albertel 2773: }
2774: unless ($errorcount) {
1.187 www 2775: my ($outstring,$error)=
1.296 raeburn 2776: &publish($docroot.$fn,$docroot.$thistarget,$thisembstyle,undef,$nokeyref);
1.246 bisitz 2777: $r->print($outstring);
1.187 www 2778: } else {
1.239 bisitz 2779: $r->print('<h3 class="LC_error">'.
1.189 albertel 2780: &mt('The document contains errors and cannot be published.').
1.187 www 2781: '</h3>');
2782: }
1.139 albertel 2783: } else {
1.296 raeburn 2784: my ($output,$error) = &phasetwo($r,$docroot.$fn,$docroot.$thistarget,
2785: $thisembstyle,$thisdistarget);
2786: $r->print($output);
1.139 albertel 2787: }
2788: }
1.208 albertel 2789: $r->print(&Apache::loncommon::end_page());
1.15 www 2790:
1.139 albertel 2791: return OK;
1.1 www 2792: }
2793:
1.296 raeburn 2794: BEGIN {
2795:
2796: # ----------------------------------- Read addid.tab
2797: unless ($readit) {
2798: %addid=();
2799:
2800: {
2801: my $tabdir = $Apache::lonnet::perlvar{'lonTabDir'};
2802: my $fh=Apache::File->new($tabdir.'/addid.tab');
2803: while (<$fh>=~/(\w+)\s+(\w+)/) {
2804: $addid{$1}=$2;
2805: }
2806: }
2807: }
2808: $readit=1;
2809: }
2810:
2811:
1.1 www 2812: 1;
2813: __END__
2814:
1.89 matthew 2815: =pod
1.126 bowersj2 2816:
2817: =back
1.66 harris41 2818:
1.89 matthew 2819: =cut
1.66 harris41 2820:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonpublisher.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / publisher