File:  [LON-CAPA] / loncom / publisher / lonpublisher.pm
Revision 1.145.2.2: download - view: text, annotated - select for diffs
Tue Feb 10 19:23:11 2004 UTC (20 years, 3 months ago) by albertel
CVS tags: version_1_1_X, version_1_1_3, version_1_1_2
Diff to branchpoint 1.145: preferred, unified
- backporting support for CSTR on multidomained machines into 1.1.X

    1: # The LearningOnline Network with CAPA
    2: # Publication Handler
    3: #
    4: # $Id: lonpublisher.pm,v 1.145.2.2 2004/02/10 19:23:11 albertel Exp $
    5: #
    6: # Copyright Michigan State University Board of Trustees
    7: #
    8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    9: #
   10: # LON-CAPA is free software; you can redistribute it and/or modify
   11: # it under the terms of the GNU General Public License as published by
   12: # the Free Software Foundation; either version 2 of the License, or
   13: # (at your option) any later version.
   14: #
   15: # LON-CAPA is distributed in the hope that it will be useful,
   16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18: # GNU General Public License for more details.
   19: #
   20: # You should have received a copy of the GNU General Public License
   21: # along with LON-CAPA; if not, write to the Free Software
   22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   23: #
   24: # /home/httpd/html/adm/gpl.txt
   25: #
   26: # http://www.lon-capa.org/
   27: #
   28: # 
   29: # (TeX Content Handler
   30: #
   31: # 05/29/00,05/30,10/11 Gerd Kortemeyer)
   32: #
   33: # 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer
   34: # 03/23 Guy Albertelli
   35: # 03/24,03/29,04/03 Gerd Kortemeyer
   36: # 05/03,05/05,05/07 Gerd Kortemeyer
   37: # 06/23,08/07,08/11,8/13,8/17,8/18,8/24,9/26,10/16 Gerd Kortemeyer
   38: # 12/04,12/05 Guy Albertelli
   39: # 12/05 Gerd Kortemeyer
   40: # 12/05 Guy Albertelli
   41: # 12/06,12/07 Gerd Kortemeyer
   42: # 12/25 Gerd Kortemeyer
   43: # YEAR=2002
   44: # 1/17 Gerd Kortemeyer
   45: #
   46: ###
   47: 
   48: ###############################################################################
   49: ##                                                                           ##
   50: ## ORGANIZATION OF THIS PERL MODULE                                          ##
   51: ##                                                                           ##
   52: ## 1. Modules used by this module                                            ##
   53: ## 2. Various subroutines                                                    ##
   54: ## 3. Publication Step One                                                   ##
   55: ## 4. Phase Two                                                              ##
   56: ## 5. Main Handler                                                           ##
   57: ##                                                                           ##
   58: ###############################################################################
   59: 
   60: 
   61: ######################################################################
   62: ######################################################################
   63: 
   64: =pod 
   65: 
   66: =head1 NAME
   67: 
   68: lonpublisher - LON-CAPA publishing handler
   69: 
   70: =head1 SYNOPSIS
   71: 
   72: B<lonpublisher> is used by B<mod_perl> inside B<Apache>.  This is the
   73: invocation by F<loncapa_apache.conf>:
   74: 
   75:   <Location /adm/publish>
   76:   PerlAccessHandler       Apache::lonacc
   77:   SetHandler perl-script
   78:   PerlHandler Apache::lonpublisher
   79:   ErrorDocument     403 /adm/login
   80:   ErrorDocument     404 /adm/notfound.html
   81:   ErrorDocument     406 /adm/unauthorized.html
   82:   ErrorDocument     500 /adm/errorhandler
   83:   </Location>
   84: 
   85: =head1 OVERVIEW
   86: 
   87: Authors can only write-access the C</~authorname/> space. They can
   88: copy resources into the resource area through the publication step,
   89: and move them back through a recover step. Authors do not have direct
   90: write-access to their resource space.
   91: 
   92: During the publication step, several events will be
   93: triggered. Metadata is gathered, where a wizard manages default
   94: entries on a hierarchical per-directory base: The wizard imports the
   95: metadata (including access privileges and royalty information) from
   96: the most recent published resource in the current directory, and if
   97: that is not available, from the next directory above, etc. The Network
   98: keeps all previous versions of a resource and makes them available by
   99: an explicit version number, which is inserted between the file name
  100: and extension, for example C<foo.2.html>, while the most recent
  101: version does not carry a version number (C<foo.html>). Servers
  102: subscribing to a changed resource are notified that a new version is
  103: available.
  104: 
  105: =head1 DESCRIPTION
  106: 
  107: B<lonpublisher> takes the proper steps to add resources to the LON-CAPA
  108: digital library.  This includes updating the metadata table in the
  109: LON-CAPA database.
  110: 
  111: B<lonpublisher> is many things to many people.  
  112: 
  113: This module publishes a file.  This involves gathering metadata,
  114: versioning the file, copying file from construction space to
  115: publication space, and copying metadata from construction space
  116: to publication space.
  117: 
  118: =head2 SUBROUTINES
  119: 
  120: Many of the undocumented subroutines implement various magical
  121: parsing shortcuts.
  122: 
  123: =over 4
  124: 
  125: =cut
  126: 
  127: ######################################################################
  128: ######################################################################
  129: 
  130: 
  131: package Apache::lonpublisher;
  132: 
  133: # ------------------------------------------------- modules used by this module
  134: use strict;
  135: use Apache::File;
  136: use File::Copy;
  137: use Apache::Constants qw(:common :http :methods);
  138: use HTML::LCParser;
  139: use Apache::lonxml;
  140: use Apache::loncacc;
  141: use DBI;
  142: use Apache::lonnet();
  143: use Apache::loncommon();
  144: use Apache::lonmysql;
  145: use Apache::lonlocal;
  146: use Apache::loncfile;
  147: use vars qw(%metadatafields %metadatakeys);
  148: 
  149: my %addid;
  150: my %nokey;
  151: 
  152: my $docroot;
  153: 
  154: my $cuname;
  155: my $cudom;
  156: 
  157: =pod
  158: 
  159: =item B<metaeval>
  160: 
  161: Evaluates a string that contains metadata.  This subroutine
  162: stores values inside I<%metadatafields> and I<%metadatakeys>.
  163: The hash key is a I<$unikey> corresponding to a unique id
  164: that is descriptive of the parser location inside the XML tree.
  165: 
  166: Parameters:
  167: 
  168: =over 4
  169: 
  170: =item I<$metastring>
  171: 
  172: A string that contains metadata.
  173: 
  174: =back
  175: 
  176: Returns:
  177: 
  178: nothing
  179: 
  180: =cut
  181: 
  182: #########################################
  183: #########################################
  184: #
  185: # Modifies global %metadatafields %metadatakeys 
  186: #
  187: 
  188: sub metaeval {
  189:     my ($metastring,$prefix)=@_;
  190:    
  191:     my $parser=HTML::LCParser->new(\$metastring);
  192:     my $token;
  193:     while ($token=$parser->get_token) {
  194: 	if ($token->[0] eq 'S') {
  195: 	    my $entry=$token->[1];
  196: 	    my $unikey=$entry;
  197: 	    if (defined($token->[2]->{'package'})) { 
  198: 		$unikey.='_package_'.$token->[2]->{'package'};
  199: 	    } 
  200: 	    if (defined($token->[2]->{'part'})) { 
  201: 		$unikey.='_'.$token->[2]->{'part'}; 
  202: 	    }
  203: 	    if (defined($token->[2]->{'id'})) { 
  204: 		$unikey.='_'.$token->[2]->{'id'};
  205: 	    } 
  206: 	    if (defined($token->[2]->{'name'})) { 
  207: 		$unikey.='_'.$token->[2]->{'name'}; 
  208: 	    }
  209: 	    foreach (@{$token->[3]}) {
  210: 		$metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};
  211: 		if ($metadatakeys{$unikey}) {
  212: 		    $metadatakeys{$unikey}.=','.$_;
  213: 		} else {
  214: 		    $metadatakeys{$unikey}=$_;
  215: 		}
  216: 	    }
  217: 	    my $newentry=$parser->get_text('/'.$entry);
  218: 	    if ($entry eq 'customdistributionfile') {
  219: 		$newentry=~s/^\s*//;
  220: 		if ($newentry !~m|^/res|) { $newentry=$prefix.$newentry; }
  221: 	    }
  222: # actually store
  223: 	    if ( $entry eq 'rule' && exists($metadatafields{$unikey})) {
  224: 		$metadatafields{$unikey}.=','.$newentry;
  225: 	    } else {
  226: 		$metadatafields{$unikey}=$newentry;
  227: 	    }
  228: 	}
  229:     }
  230: }
  231: 
  232: #########################################
  233: #########################################
  234: 
  235: =pod
  236: 
  237: =item B<metaread>
  238: 
  239: Read a metadata file
  240: 
  241: Parameters:
  242: 
  243: =over
  244: 
  245: =item I<$logfile>
  246: 
  247: File output stream to output errors and warnings to.
  248: 
  249: =item I<$fn>
  250: 
  251: File name (including path).
  252: 
  253: =back
  254: 
  255: Returns:
  256: 
  257: =over 4
  258: 
  259: =item Scalar string (if successful)
  260: 
  261: XHTML text that indicates successful reading of the metadata.
  262: 
  263: =back
  264: 
  265: =cut
  266: 
  267: #########################################
  268: #########################################
  269: sub metaread {
  270:     my ($logfile,$fn,$prefix)=@_;
  271:     unless (-e $fn) {
  272: 	print($logfile 'No file '.$fn."\n");
  273:         return '<br /><b>No file:</b> <tt>'.
  274: 	    &Apache::loncfile::display($fn).'</tt>';
  275:     }
  276:     print($logfile 'Processing '.$fn."\n");
  277:     my $metastring;
  278:     {
  279: 	my $metafh=Apache::File->new($fn);
  280: 	$metastring=join('',<$metafh>);
  281:     }
  282:     &metaeval($metastring,$prefix);
  283:     return '<br /><b>Processed file:</b> <tt>'.
  284: 	&Apache::loncfile::display($fn).'</tt>';
  285: }
  286: 
  287: #########################################
  288: #########################################
  289: 
  290: sub coursedependencies {
  291:     my $url=&Apache::lonnet::declutter(shift);
  292:     $url=~s/\.meta$//;
  293:     my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//);
  294:     my $regexp=$url;
  295:     $regexp=~s/(\W)/\\$1/g;
  296:     $regexp='___'.$regexp.'___course';
  297:     my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain,
  298: 				       $aauthor,$regexp);
  299:     my %courses=();
  300:     foreach (keys %evaldata) {
  301: 	if ($_=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) {
  302: 	    $courses{$1}=1;
  303:         }
  304:     }
  305:     return %courses;
  306: }
  307: #########################################
  308: #########################################
  309: 
  310: 
  311: =pod
  312: 
  313: =item Form-field-generating subroutines.
  314: 
  315: For input parameters, these subroutines take in values
  316: such as I<$name>, I<$value> and other form field metadata.
  317: The output (scalar string that is returned) is an XHTML
  318: string which presents the form field (foreseeably inside
  319: <form></form> tags).
  320: 
  321: =over 4
  322: 
  323: =item B<textfield>
  324: 
  325: =item B<hiddenfield>
  326: 
  327: =item B<selectbox>
  328: 
  329: =back
  330: 
  331: =cut
  332: 
  333: #########################################
  334: #########################################
  335: sub textfield {
  336:     my ($title,$name,$value)=@_;
  337:     $value=~s/^\s+//gs;
  338:     $value=~s/\s+$//gs;
  339:     $value=~s/\s+/ /gs;
  340:     $title=&mt($title);
  341:     my $uctitle=uc($title);
  342:     return "\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".
  343:            "</b></font></p><br />".
  344:            '<input type="text" name="'.$name.'" size=80 value="'.$value.'" />';
  345: }
  346: 
  347: sub hiddenfield {
  348:     my ($name,$value)=@_;
  349:     return "\n".'<input type="hidden" name="'.$name.'" value="'.$value.'" />';
  350: }
  351: 
  352: sub selectbox {
  353:     my ($title,$name,$value,$functionref,@idlist)=@_;
  354:     $title=&mt($title);
  355:     my $uctitle=uc($title);
  356:     $value=(split(/\s*,\s*/,$value))[-1];
  357:     my $selout="\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".
  358: 	'</b></font></p><br /><select name="'.$name.'">';
  359:     foreach (@idlist) {
  360:         $selout.='<option value=\''.$_.'\'';
  361:         if ($_ eq $value) {
  362: 	    $selout.=' selected>'.&{$functionref}($_).'</option>';
  363: 	}
  364:         else {$selout.='>'.&{$functionref}($_).'</option>';}
  365:     }
  366:     return $selout.'</select>';
  367: }
  368: 
  369: #########################################
  370: #########################################
  371: 
  372: =pod
  373: 
  374: =item B<urlfixup>
  375: 
  376: Fix up a url?  First step of publication
  377: 
  378: =cut
  379: 
  380: #########################################
  381: #########################################
  382: sub urlfixup {
  383:     my ($url,$target)=@_;
  384:     unless ($url) { return ''; }
  385:     #javascript code needs no fixing
  386:     if ($url =~ /^javascript:/i) { return $url; }
  387:     if ($url =~ /^mailto:/i) { return $url; }
  388:     #internal document links need no fixing
  389:     if ($url =~ /^\#/) { return $url; } 
  390:     my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/);
  391:     foreach (values %Apache::lonnet::hostname) {
  392: 	if ($_ eq $host) {
  393: 	    $url=~s/^http\:\/\///;
  394:             $url=~s/^$host//;
  395:         }
  396:     }
  397:     if ($url=~/^http\:\/\//) { return $url; }
  398:     $url=~s/\~$cuname/res\/$cudom\/$cuname/;
  399:     return $url;
  400: }
  401: 
  402: #########################################
  403: #########################################
  404: 
  405: =pod
  406: 
  407: =item B<absoluteurl>
  408: 
  409: Currently undocumented.
  410: 
  411: =cut
  412: 
  413: #########################################
  414: #########################################
  415: sub absoluteurl {
  416:     my ($url,$target)=@_;
  417:     unless ($url) { return ''; }
  418:     if ($target) {
  419: 	$target=~s/\/[^\/]+$//;
  420:        $url=&Apache::lonnet::hreflocation($target,$url);
  421:     }
  422:     return $url;
  423: }
  424: 
  425: #########################################
  426: #########################################
  427: 
  428: =pod
  429: 
  430: =item B<set_allow>
  431: 
  432: Currently undocumented    
  433: 
  434: =cut
  435: 
  436: #########################################
  437: #########################################
  438: sub set_allow {
  439:     my ($allow,$logfile,$target,$tag,$oldurl)=@_;
  440:     my $newurl=&urlfixup($oldurl,$target);
  441:     my $return_url=$oldurl;
  442:     print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n";
  443:     if ($newurl ne $oldurl) {
  444: 	$return_url=$newurl;
  445: 	print $logfile 'URL: '.$tag.':'.$oldurl.' - '.$newurl."\n";
  446:     }
  447:     if (($newurl !~ /^javascript:/i) &&
  448: 	($newurl !~ /^mailto:/i) &&
  449: 	($newurl !~ /^http:/i) &&
  450: 	($newurl !~ /^\#/)) {
  451: 	$$allow{&absoluteurl($newurl,$target)}=1;
  452:     }
  453:     return $return_url
  454: }
  455: 
  456: #########################################
  457: #########################################
  458: 
  459: =pod
  460: 
  461: =item B<get_subscribed_hosts>
  462: 
  463: Currently undocumented    
  464: 
  465: =cut
  466: 
  467: #########################################
  468: #########################################
  469: sub get_subscribed_hosts {
  470:     my ($target)=@_;
  471:     my @subscribed;
  472:     my $filename;
  473:     $target=~/(.*)\/([^\/]+)$/;
  474:     my $srcf=$2;
  475:     opendir(DIR,$1);
  476:     while ($filename=readdir(DIR)) {
  477: 	if ($filename=~/\Q$srcf\E\.(\w+)$/) {
  478: 	    my $subhost=$1;
  479: 	    if (($subhost ne 'meta' && $subhost ne 'subscription') &&
  480:                 ($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) {
  481: 		push(@subscribed,$subhost);
  482: 	    }
  483: 	}
  484:     }
  485:     closedir(DIR);
  486:     my $sh;
  487:     if ( $sh=Apache::File->new("$target.subscription") ) {
  488: 	&Apache::lonnet::logthis("opened $target.subscription");
  489: 	while (my $subline=<$sh>) {
  490: 	    &Apache::lonnet::logthis("Trying $subline");
  491: 	    if ($subline =~ /(^\w+):/) { 
  492:                 if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) { 
  493:                    push(@subscribed,$1);
  494: 	        }
  495:             } else {
  496: 		&Apache::lonnet::logthis("No Match for $subline");
  497: 	    }
  498: 	}
  499:     } else {
  500: 	&Apache::lonnet::logthis("Unable to open $target.subscription");
  501:     }
  502:     return @subscribed;
  503: }
  504: 
  505: 
  506: #########################################
  507: #########################################
  508: 
  509: =pod
  510: 
  511: =item B<get_max_ids_indices>
  512: 
  513: Currently undocumented    
  514: 
  515: =cut
  516: 
  517: #########################################
  518: #########################################
  519: sub get_max_ids_indices {
  520:     my ($content)=@_;
  521:     my $maxindex=10;
  522:     my $maxid=10;
  523:     my $needsfixup=0;
  524:     my $duplicateids=0;
  525: 
  526:     my %allids;
  527:     my %duplicatedids;
  528: 
  529:     my $parser=HTML::LCParser->new($content);
  530:     my $token;
  531:     while ($token=$parser->get_token) {
  532: 	if ($token->[0] eq 'S') {
  533: 	    my $counter;
  534: 	    if ($counter=$addid{$token->[1]}) {
  535: 		if ($counter eq 'id') {
  536: 		    if (defined($token->[2]->{'id'})) {
  537: 			$maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
  538: 			if (exists($allids{$token->[2]->{'id'}})) {
  539: 			    $duplicateids=1;
  540: 			    $duplicatedids{$token->[2]->{'id'}}=1;
  541: 			} else {
  542: 			    $allids{$token->[2]->{'id'}}=1;
  543: 			}
  544: 		    } else {
  545: 			$needsfixup=1;
  546: 		    }
  547: 		} else {
  548: 		    if (defined($token->[2]->{'index'})) {
  549: 			$maxindex=($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
  550: 		    } else {
  551: 			$needsfixup=1;
  552: 		    }
  553: 		}
  554: 	    }
  555: 	}
  556:     }
  557:     return ($needsfixup,$maxid,$maxindex,$duplicateids,
  558: 	    (keys(%duplicatedids)));
  559: }
  560: 
  561: #########################################
  562: #########################################
  563: 
  564: =pod
  565: 
  566: =item B<get_all_text_unbalanced>
  567: 
  568: Currently undocumented    
  569: 
  570: =cut
  571: 
  572: #########################################
  573: #########################################
  574: sub get_all_text_unbalanced {
  575:     #there is a copy of this in lonxml.pm
  576:     my($tag,$pars)= @_;
  577:     my $token;
  578:     my $result='';
  579:     $tag='<'.$tag.'>';
  580:     while ($token = $$pars[-1]->get_token) {
  581: 	if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) {
  582: 	    $result.=$token->[1];
  583: 	} elsif ($token->[0] eq 'PI') {
  584: 	    $result.=$token->[2];
  585: 	} elsif ($token->[0] eq 'S') {
  586: 	    $result.=$token->[4];
  587: 	} elsif ($token->[0] eq 'E')  {
  588: 	    $result.=$token->[2];
  589: 	}
  590: 	if ($result =~ /(.*)\Q$tag\E(.*)/s) {
  591: 	    #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2);
  592: 	    #&Apache::lonnet::logthis('Result is :'.$1);
  593: 	    $result=$1;
  594: 	    my $redo=$tag.$2;
  595: 	    push (@$pars,HTML::LCParser->new(\$redo));
  596: 	    $$pars[-1]->xml_mode('1');
  597: 	    last;
  598: 	}
  599:     }
  600:     return $result
  601: }
  602: 
  603: #########################################
  604: #########################################
  605: 
  606: =pod
  607: 
  608: =item B<fix_ids_and_indices>
  609: 
  610: Currently undocumented    
  611: 
  612: =cut
  613: 
  614: #########################################
  615: #########################################
  616: #Arguably this should all be done as a lonnet::ssi instead
  617: sub fix_ids_and_indices {
  618:     my ($logfile,$source,$target)=@_;
  619: 
  620:     my %allow;
  621:     my $content;
  622:     {
  623: 	my $org=Apache::File->new($source);
  624: 	$content=join('',<$org>);
  625:     }
  626: 
  627:     my ($needsfixup,$maxid,$maxindex,$duplicateids,@duplicatedids)=
  628: 	&get_max_ids_indices(\$content);
  629: 
  630:     print $logfile ("Got $needsfixup,$maxid,$maxindex,$duplicateids--".
  631: 			   join(', ',@duplicatedids));
  632:     if ($duplicateids) {
  633: 	print $logfile "Duplicate ID(s) exist, ".join(', ',@duplicatedids)."\n";
  634: 	my $outstring='<font color="red">Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are: '.join(', ',@duplicatedids).'</font>';
  635: 	return ($outstring,1);
  636:     }
  637:     if ($needsfixup) {
  638: 	print $logfile "Needs ID and/or index fixup\n".
  639: 	    "Max ID   : $maxid (min 10)\n".
  640:                 "Max Index: $maxindex (min 10)\n";
  641:     }
  642:     my $outstring='';
  643:     my @parser;
  644:     $parser[0]=HTML::LCParser->new(\$content);
  645:     $parser[-1]->xml_mode(1);
  646:     my $token;
  647:     while (@parser) {
  648: 	while ($token=$parser[-1]->get_token) {
  649: 	    if ($token->[0] eq 'S') {
  650: 		my $counter;
  651: 		my $tag=$token->[1];
  652: 		my $lctag=lc($tag);
  653: 		if ($lctag eq 'allow') {
  654: 		    $allow{$token->[2]->{'src'}}=1;
  655: 		    next;
  656: 		}
  657: 		my %parms=%{$token->[2]};
  658: 		$counter=$addid{$tag};
  659: 		if (!$counter) { $counter=$addid{$lctag}; }
  660: 		if ($counter) {
  661: 		    if ($counter eq 'id') {
  662: 			unless (defined($parms{'id'})) {
  663: 			    $maxid++;
  664: 			    $parms{'id'}=$maxid;
  665: 			    print $logfile 'ID: '.$tag.':'.$maxid."\n";
  666: 			}
  667: 		    } elsif ($counter eq 'index') {
  668: 			unless (defined($parms{'index'})) {
  669: 			    $maxindex++;
  670: 			    $parms{'index'}=$maxindex;
  671: 			    print $logfile 'Index: '.$tag.':'.$maxindex."\n";
  672: 			}
  673: 		    }
  674: 		}
  675: 		foreach my $type ('src','href','background','bgimg') {
  676: 		    foreach my $key (keys(%parms)) {
  677: 			if ($key =~ /^$type$/i) {
  678: 			    $parms{$key}=&set_allow(\%allow,$logfile,
  679: 						    $target,$tag,
  680: 						    $parms{$key});
  681: 			}
  682: 		    }
  683: 		}
  684: 		# probably a <randomlabel> image type <label>
  685: 		# or a <image> tag inside <imageresponse>
  686: 		if (($lctag eq 'label' && defined($parms{'description'}))
  687: 		    ||
  688: 		    ($lctag eq 'image')) {
  689: 		    my $next_token=$parser[-1]->get_token();
  690: 		    if ($next_token->[0] eq 'T') {
  691: 			$next_token->[1]=&set_allow(\%allow,$logfile,
  692: 						    $target,$tag,
  693: 						    $next_token->[1]);
  694: 		    }
  695: 		    $parser[-1]->unget_token($next_token);
  696: 		}
  697: 		if ($lctag eq 'applet') {
  698: 		    my $codebase='';
  699: 		    if (defined($parms{'codebase'})) {
  700: 			my $oldcodebase=$parms{'codebase'};
  701: 			unless ($oldcodebase=~/\/$/) {
  702: 			    $oldcodebase.='/';
  703: 			}
  704: 			$codebase=&urlfixup($oldcodebase,$target);
  705: 			$codebase=~s/\/$//;    
  706: 			if ($codebase ne $oldcodebase) {
  707: 			    $parms{'codebase'}=$codebase;
  708: 			    print $logfile 'URL codebase: '.$tag.':'.
  709: 				$oldcodebase.' - '.
  710: 				    $codebase."\n";
  711: 			}
  712: 			$allow{&absoluteurl($codebase,$target).'/*'}=1;
  713: 		    } else {
  714: 			foreach ('archive','code','object') {
  715: 			    if (defined($parms{$_})) {
  716: 				my $oldurl=$parms{$_};
  717: 				my $newurl=&urlfixup($oldurl,$target);
  718: 				$newurl=~s/\/[^\/]+$/\/\*/;
  719: 				print $logfile 'Allow: applet '.$_.':'.
  720: 				    $oldurl.' allows '.
  721: 					$newurl."\n";
  722: 				$allow{&absoluteurl($newurl,$target)}=1;
  723: 			    }
  724: 			}
  725: 		    }
  726: 		}
  727: 		my $newparmstring='';
  728: 		my $endtag='';
  729: 		foreach (keys %parms) {
  730: 		    if ($_ eq '/') {
  731: 			$endtag=' /';
  732: 		    } else { 
  733: 			my $quote=($parms{$_}=~/\"/?"'":'"');
  734: 			$newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
  735: 		    }
  736: 		}
  737: 		if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
  738: 		$outstring.='<'.$tag.$newparmstring.$endtag.'>';
  739: 		if ($lctag eq 'm' || $lctag eq 'script' 
  740:                     || $lctag eq 'display' || $lctag eq 'tex') {
  741: 		    $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser);
  742: 		}
  743: 	    } elsif ($token->[0] eq 'E') {
  744: 		if ($token->[2]) {
  745: 		    unless ($token->[1] eq 'allow') {
  746: 			$outstring.='</'.$token->[1].'>';
  747: 		    }
  748: 		}
  749: 	    } else {
  750: 		$outstring.=$token->[1];
  751: 	    }
  752: 	}
  753: 	pop(@parser);
  754:     }
  755: 
  756:     if ($needsfixup) {
  757: 	print $logfile "End of ID and/or index fixup\n".
  758: 	    "Max ID   : $maxid (min 10)\n".
  759: 		"Max Index: $maxindex (min 10)\n";
  760:     } else {
  761: 	print $logfile "Does not need ID and/or index fixup\n";
  762:     }
  763: 
  764:     return ($outstring,0,%allow);
  765: }
  766: 
  767: #########################################
  768: #########################################
  769: 
  770: =pod
  771: 
  772: =item B<store_metadata>
  773: 
  774: Store the metadata in the metadata table in the loncapa database.
  775: Uses lonmysql to access the database.
  776: 
  777: Inputs: \%metadata
  778: 
  779: Returns: (error,status).  error is undef on success, status is undef on error.
  780: 
  781: =cut
  782: 
  783: #########################################
  784: #########################################
  785: sub store_metadata {
  786:     my %metadata = %{shift()};
  787:     my $error;
  788:     # Determine if the table exists
  789:     my $status = &Apache::lonmysql::check_table('metadata');
  790:     if (! defined($status)) {
  791:         $error='<font color="red">WARNING: Cannot connect to '.
  792:             'database!</font>';
  793:         &Apache::lonnet::logthis($error);
  794:         return ($error,undef);
  795:     }
  796:     if ($status == 0) {
  797:         # It would be nice to actually create the table....
  798:         $error ='<font color="red">WARNING: The metadata table does not '.
  799:             'exist in the LON-CAPA database.</font>';
  800:         &Apache::lonnet::logthis($error);
  801:         return ($error,undef);
  802:     }
  803:     # Remove old value from table
  804:     $status = &Apache::lonmysql::remove_from_table
  805:         ('metadata','url',$metadata{'url'});
  806:     if (! defined($status)) {
  807:         $error = '<font color="red">Error when removing old values from '.
  808:             'metadata table in LON-CAPA database.</font>';
  809:         &Apache::lonnet::logthis($error);
  810:         return ($error,undef);
  811:     }
  812:     # Store data in table.
  813:     $status = &Apache::lonmysql::store_row('metadata',\%metadata);
  814:     if (! defined($status)) {
  815:         $error='<font color="red">Error occured storing new values in '.
  816:             'metadata table in LON-CAPA database</font>';
  817:         &Apache::lonnet::logthis($error);
  818:         return ($error,undef);
  819:     }
  820:     return (undef,$status);
  821: }
  822: 
  823: 
  824: # ============================================== Parse file itself for metadata
  825: #
  826: # parses a file with target meta, sets global %metadatafields %metadatakeys 
  827: 
  828: sub parseformeta {
  829:     my ($source,$style)=@_;
  830:     my $allmeta='';
  831:     if (($style eq 'ssi') || ($style eq 'prv')) {
  832: 	my $dir=$source;
  833: 	$dir=~s-/[^/]*$--;
  834: 	my $file=$source;
  835: 	$file=(split('/',$file))[-1];
  836:         $source=&Apache::lonnet::hreflocation($dir,$file);
  837: 	$allmeta=&Apache::lonnet::ssi_body($source,('grade_target' => 'meta'));
  838:         &metaeval($allmeta);
  839:     }
  840:     return $allmeta;
  841: }
  842: 
  843: #########################################
  844: #########################################
  845: 
  846: =pod
  847: 
  848: =item B<publish>
  849: 
  850: This is the workhorse function of this module.  This subroutine generates
  851: backup copies, performs any automatic processing (prior to publication,
  852: especially for rat and ssi files),
  853: 
  854: Returns a 2 element array, the first is the string to be shown to the
  855: user, the second is an error code, either 1 (an error occured) or 0
  856: (no error occurred)
  857: 
  858: I<Additional documentation needed.>
  859: 
  860: =cut
  861: 
  862: #########################################
  863: #########################################
  864: sub publish {
  865: 
  866:     my ($source,$target,$style,$batch)=@_;
  867:     my $logfile;
  868:     my $scrout='';
  869:     my $allmeta='';
  870:     my $content='';
  871:     my %allow=();
  872: 
  873:     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
  874: 	return ('<font color="red">No write permission to user directory, FAIL</font>',1);
  875:     }
  876:     print $logfile 
  877: "\n\n================= Publish ".localtime()." Phase One  ================\n".$ENV{'user.name'}.'@'.$ENV{'user.domain'}."\n";
  878: 
  879:     if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) {
  880: # ------------------------------------------------------- This needs processing
  881: 
  882: # ----------------------------------------------------------------- Backup Copy
  883: 	my $copyfile=$source.'.save';
  884:         if (copy($source,$copyfile)) {
  885: 	    print $logfile "Copied original file to ".$copyfile."\n";
  886:         } else {
  887: 	    print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";
  888: 	    return ("<font color=\"red\">Failed to write backup copy, $!,FAIL</font>",1);
  889:         }
  890: # ------------------------------------------------------------- IDs and indices
  891: 	
  892: 	my ($outstring,$error);
  893: 	($outstring,$error,%allow)=&fix_ids_and_indices($logfile,$source,
  894: 							$target);
  895: 	if ($error) { return ($outstring,$error); }
  896: # ------------------------------------------------------------ Construct Allows
  897:     
  898: 	$scrout.='<h3>Dependencies</h3>';
  899:         my $allowstr='';
  900:         foreach (sort(keys(%allow))) {
  901: 	   my $thisdep=$_;
  902: 	   if ($thisdep !~ /[^\s]/) { next; }
  903:            unless ($style eq 'rat') { 
  904:               $allowstr.="\n".'<allow src="'.$thisdep.'" />';
  905: 	   }
  906:            $scrout.='<br />';
  907:            unless ($thisdep=~/\*/) {
  908: 	       $scrout.='<a href="'.$thisdep.'">';
  909:            }
  910:            $scrout.='<tt>'.$thisdep.'</tt>';
  911:            unless ($thisdep=~/\*/) {
  912: 	       $scrout.='</a>';
  913:                if (
  914:        &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
  915:                                             $thisdep.'.meta') eq '-1') {
  916: 		   $scrout.= ' - <font color="red">Currently not available'.
  917: 		       '</font>';
  918:                } else {
  919:                    my %temphash=(&Apache::lonnet::declutter($target).'___'.
  920:                              &Apache::lonnet::declutter($thisdep).'___usage'
  921:                                  => time);
  922:                    $thisdep=~/^\/res\/(\w+)\/(\w+)\//;
  923:                    if ((defined($1)) && (defined($2))) {
  924:                       &Apache::lonnet::put('nohist_resevaldata',\%temphash,
  925: 					   $1,$2);
  926: 		   }
  927: 	       }
  928:            }
  929:         }
  930:         $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s;
  931: 
  932: ### FIXME: is this really what we want?
  933: # I dont' think so, to will corrupt any UTF-8 resources at least, 
  934: # and any encoding other than ISO-8859-1 will probably break
  935: 	#Encode any High ASCII characters
  936: 	#$outstring=&HTML::Entities::encode($outstring,"\200-\377");
  937: # ------------------------------------------------------------- Write modified.
  938: 
  939:         {
  940:           my $org;
  941:           unless ($org=Apache::File->new('>'.$source)) {
  942:              print $logfile "No write permit to $source\n";
  943:              return ('<font color="red">'.&mt('No write permission to').
  944: 		     ' '.$source.
  945: 		     ', '.&mt('FAIL').'</font>',1);
  946: 	  }
  947:           print($org $outstring);
  948:         }
  949: 	  $content=$outstring;
  950: 
  951:     }
  952: # -------------------------------------------- Initial step done, now metadata.
  953: 
  954: # --------------------------------------- Storage for metadata keys and fields.
  955: # these are globals
  956: #
  957:      %metadatafields=();
  958:      %metadatakeys=();
  959:      
  960:      my %oldparmstores=();
  961:      
  962:     unless ($batch) {
  963:      $scrout.='<h3>'.&mt('Metadata Information').' ' .
  964:        Apache::loncommon::help_open_topic("Metadata_Description")
  965:        . '</h3>';
  966:     }
  967: 
  968: # ------------------------------------------------ First, check out environment
  969:      unless (-e $source.'.meta') {
  970:         $metadatafields{'author'}=$ENV{'environment.firstname'}.' '.
  971: 	                          $ENV{'environment.middlename'}.' '.
  972: 		                  $ENV{'environment.lastname'}.' '.
  973: 		                  $ENV{'environment.generation'};
  974:         $metadatafields{'author'}=~s/\s+/ /g;
  975:         $metadatafields{'author'}=~s/\s+$//;
  976:         $metadatafields{'owner'}=$cuname.'@'.$cudom;
  977: 	$metadatafields{'modifyinguser'}=$ENV{'user.name'}.'@'.
  978: 	                                 $ENV{'user.domain'};
  979: 	$metadatafields{'authorspace'}=$cuname.'@'.$cudom;
  980: 
  981: # ----------------------------------------------------------- Parse file itself
  982: # read %metadatafields from file itself
  983:  
  984: 	$allmeta=&parseformeta($source,$style);
  985: # ------------------------------------------------ Check out directory hierachy
  986: 
  987:         my $thisdisfn=$source;
  988:         $thisdisfn=~s/^\/home\/\Q$cuname\E\///;
  989: 
  990:         my @urlparts=split(/\//,$thisdisfn);
  991:         $#urlparts--;
  992: 
  993:         my $currentpath='/home/'.$cuname.'/';
  994: 
  995: 	my $prefix='../'x($#urlparts);
  996:         foreach (@urlparts) {
  997: 	    $currentpath.=$_.'/';
  998:             $scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix);
  999: 	    $prefix=~s|^\.\./||;
 1000:         }
 1001: 
 1002: # ------------------- Clear out parameters and stores (there should not be any)
 1003: 
 1004:         foreach (keys %metadatafields) {
 1005: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
 1006: 		delete $metadatafields{$_};
 1007:             }
 1008:         }
 1009: 
 1010:     } else {
 1011: # ---------------------- Read previous metafile, remember parameters and stores
 1012: 
 1013:         $scrout.=&metaread($logfile,$source.'.meta');
 1014: 
 1015:         foreach (keys %metadatafields) {
 1016: 	    if (($_=~/^parameter/) || ($_=~/^stores/)) {
 1017:                 $oldparmstores{$_}=1;
 1018: 		delete $metadatafields{$_};
 1019:             }
 1020:         }
 1021: # ------------------------------------------ See if anything new in file itself
 1022:  
 1023: 	$allmeta=&parseformeta($source,$style);
 1024:    }
 1025: 
 1026:        
 1027: # ---------------- Find and document discrepancies in the parameters and stores
 1028: 
 1029:     my $chparms='';
 1030:     foreach (sort keys %metadatafields) {
 1031: 	if (($_=~/^parameter/) || ($_=~/^stores/)) {
 1032: 	    unless ($_=~/\.\w+$/) { 
 1033: 		unless ($oldparmstores{$_}) {
 1034: 		    print $logfile 'New: '.$_."\n";
 1035: 		    $chparms.=$_.' ';
 1036: 		}
 1037: 	    }
 1038: 	}
 1039:     }
 1040:     if ($chparms) {
 1041: 	$scrout.='<p><b>'.&mt('New parameters or stored values').
 1042: 	    ':</b> '.$chparms.'</p>';
 1043:     }
 1044: 
 1045:     $chparms='';
 1046:     foreach (sort keys %oldparmstores) {
 1047: 	if (($_=~/^parameter/) || ($_=~/^stores/)) {
 1048: 	    unless (($metadatafields{$_.'.name'}) ||
 1049: 		    ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) {
 1050: 		print $logfile 'Obsolete: '.$_."\n";
 1051: 		$chparms.=$_.' ';
 1052: 	    }
 1053: 	}
 1054:     }
 1055:     if ($chparms) {
 1056: 	$scrout.='<p><b>'.&mt('Obsolete parameters or stored values').':</b> '.
 1057: 	    $chparms.'</p><h1><font color="red">'.&mt('Warning!').
 1058: 	    '</font></h1><p><font color="red" size="+1">'.
 1059: 	    &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').'</font></p><hr />';
 1060:     }
 1061: 
 1062: # ------------------------------------------------------- Now have all metadata
 1063: 
 1064:     my %keywords=();
 1065:         
 1066:     if (length($content)<500000) {
 1067: 	my $textonly=$content;
 1068: 	$textonly=~s/\<script[^\<]+\<\/script\>//g;
 1069: 	$textonly=~s/\<m\>[^\<]+\<\/m\>//g;
 1070: 	$textonly=~s/\<[^\>]*\>//g;
 1071: 	$textonly=~tr/A-Z/a-z/;
 1072: 	$textonly=~s/[\$\&][a-z]\w*//g;
 1073: 	$textonly=~s/[^a-z\s]//g;
 1074: 	
 1075: 	foreach ($textonly=~m/(\w+)/g) {
 1076: 	    unless ($nokey{$_}) {
 1077: 		$keywords{$_}=1;
 1078: 	    } 
 1079: 	}
 1080:     }
 1081: 
 1082:             
 1083:     foreach (split(/\W+/,$metadatafields{'keywords'})) {
 1084: 	$keywords{$_}=1;
 1085:     }
 1086: # --------------------------------------------------- Now we also have keywords
 1087: # =============================================================================
 1088: # INTERACTIVE MODE
 1089: #
 1090:     unless ($batch) {
 1091:         $scrout.=
 1092: 	    '<form name="pubform" action="/adm/publish" method="post">'.
 1093:             '<p><input type="submit" value="Finalize Publication" /></p>'.
 1094:             &hiddenfield('phase','two').
 1095:             &hiddenfield('filename',$ENV{'form.filename'}).
 1096: 	    &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)).
 1097:             &hiddenfield('dependencies',join(',',keys %allow)).
 1098:             &textfield('Title','title',$metadatafields{'title'}).
 1099:             &textfield('Author(s)','author',$metadatafields{'author'}).
 1100: 	    &textfield('Subject','subject',$metadatafields{'subject'});
 1101: 
 1102: # --------------------------------------------------- Scan content for keywords
 1103: 
 1104:         my $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords");
 1105: 	my $keywordout=<<"END";
 1106: <script>
 1107: function checkAll(field) {
 1108:     for (i = 0; i < field.length; i++)
 1109:         field[i].checked = true ;
 1110: }
 1111: 
 1112: function uncheckAll(field) {
 1113:     for (i = 0; i < field.length; i++)
 1114:         field[i].checked = false ;
 1115: }
 1116: </script>
 1117: <p><font color="#800000" face="helvetica"><b>KEYWORDS:</b></font>
 1118:  $keywords_help</b>
 1119: <input type="button" value="check all" onclick="javascript:checkAll(document.pubform.keywords)" /> 
 1120: <input type="button" value="uncheck all" onclick="javascript:uncheckAll(document.pubform.keywords)" /> 
 1121: </p>
 1122: <br />
 1123: END
 1124: 	$keywordout.='<table border="2"><tr>';
 1125: 	my $colcount=0;
 1126: 
 1127: 	foreach (sort keys %keywords) {
 1128: 	    $keywordout.='<td><input type="checkbox" name="keywords" value="'.$_.'"';
 1129: 	    if ($metadatafields{'keywords'}) {
 1130: 		if ($metadatafields{'keywords'}=~/\Q$_\E/) {
 1131: 		    $keywordout.=' checked="on"';
 1132: 		}
 1133: 	    } elsif (&Apache::loncommon::keyword($_)) {
 1134: 		$keywordout.=' checked="on"';
 1135: 	    }
 1136: 	    $keywordout.=' />'.$_.'</td>';
 1137: 	    if ($colcount>10) {
 1138: 		$keywordout.="</tr><tr>\n";
 1139: 		$colcount=0;
 1140: 	    }
 1141: 	    $colcount++;
 1142: 	}
 1143: 
 1144: 	$keywordout.='</tr></table>';
 1145: 
 1146: 	$scrout.=$keywordout;
 1147: 
 1148: 	$scrout.=&textfield('Additional Keywords','addkey','');
 1149: 
 1150: 	$scrout.=&textfield('Notes','notes',$metadatafields{'notes'});
 1151: 
 1152: 	$scrout.=
 1153: 	    "\n<p><font color=\"#800000\" face=\"helvetica\"><b>ABSTRACT:".
 1154: 	    "</b></font></p><br />".
 1155: 	    '<textarea cols="80" rows="5" name="abstract">'.
 1156: 	    $metadatafields{'abstract'}.'</textarea></p>';
 1157: 
 1158: 	$source=~/\.(\w+)$/;
 1159: 
 1160: 	$scrout.=&hiddenfield('mime',$1);
 1161: 
 1162: 	my $defaultlanguage=$metadatafields{'language'};
 1163: 	$defaultlanguage =~ s/\s*notset\s*//g;
 1164: 	$defaultlanguage =~ s/^,\s*//g;
 1165: 	$defaultlanguage =~ s/,\s*$//g;
 1166: 
 1167: 	$scrout.=&selectbox('Language','language',
 1168: 			    $defaultlanguage,
 1169: 			    \&Apache::loncommon::languagedescription,
 1170: 			    (&Apache::loncommon::languageids),
 1171: 			   );
 1172: 
 1173: 	unless ($metadatafields{'creationdate'}) {
 1174: 	    $metadatafields{'creationdate'}=time;
 1175: 	}
 1176: 	$scrout.=&hiddenfield('creationdate',
 1177: 			      &Apache::loncommon::unsqltime($metadatafields{'creationdate'}));
 1178: 
 1179: 	$scrout.=&hiddenfield('lastrevisiondate',time);
 1180: 
 1181: 
 1182: 	$scrout.=&textfield('Publisher/Owner','owner',
 1183: 			    $metadatafields{'owner'});
 1184: 
 1185: # -------------------------------------------------- Correct copyright for rat.
 1186:         my $defaultoption=$metadatafields{'copyright'};
 1187:         unless ($defaultoption) { $defaultoption='default'; }
 1188: 	unless ($style eq 'prv') {
 1189: 	    if ($style eq 'rat') {
 1190: 		if ($metadatafields{'copyright'} eq 'public') { 
 1191: 		    delete $metadatafields{'copyright'};
 1192:                     $defaultoption='default';
 1193: 		}
 1194: 		$scrout.=&selectbox('Copyright/Distribution','copyright',
 1195: 				    $defaultoption,
 1196: 				    \&Apache::loncommon::copyrightdescription,
 1197: 				    (grep !/^public$/,(&Apache::loncommon::copyrightids)));
 1198: 	    } else {
 1199: 		$scrout.=&selectbox('Copyright/Distribution','copyright',
 1200: 				    $defaultoption,
 1201: 				    \&Apache::loncommon::copyrightdescription,
 1202: 				    (&Apache::loncommon::copyrightids));
 1203: 	    }
 1204:     
 1205: 	    my $copyright_help =
 1206: 		Apache::loncommon::help_open_topic('Publishing_Copyright');
 1207: 	    $scrout =~ s/DISTRIBUTION:/'DISTRIBUTION: ' . $copyright_help/ge;
 1208: 	    $scrout.=&textfield('Custom Distribution File','customdistributionfile',
 1209: 				$metadatafields{'customdistributionfile'}).
 1210: 				    $copyright_help;
 1211: 	    my $uctitle=uc(&mt('Obsolete'));
 1212:             $scrout.=
 1213: 		"\n<p><font color=\"#800000\" face=\"helvetica\"><b>$uctitle:".
 1214: 		'</b></font> <input type="checkbox" name="obsolete" ';
 1215: 	    if ($metadatafields{'obsolete'}) {
 1216: 		$scrout.=' checked="1" ';
 1217: 	    }
 1218: 	    $scrout.='/ ></p>'.
 1219: 		&textfield('Suggested Replacement for Obsolete File',
 1220: 				    'obsoletereplacement',
 1221: 				    $metadatafields{'obsoletereplacement'});
 1222: 	} else {
 1223: 	    $scrout.=&hiddenfield('copyright','private');
 1224: 	}
 1225: 	return ($scrout.'<p><input type="submit" value="'.
 1226: 		&mt('Finalize Publication').'" /></p></form>',0);
 1227: # =============================================================================
 1228: # BATCH MODE
 1229: #
 1230:     } else {
 1231: # Transfer metadata directly to environment for stage 2
 1232: 	foreach (keys %metadatafields) {
 1233: 	    $ENV{'form.'.$_}=$metadatafields{$_};
 1234: 	}
 1235: 	$ENV{'form.addkey'}='';
 1236: 	$ENV{'form.keywords'}='';
 1237: 	foreach (keys %keywords) {
 1238: 	    if ($metadatafields{'keywords'}) {
 1239: 		if ($metadatafields{'keywords'}=~/\Q$_\E/) { 
 1240: 		    $ENV{'form.keywords'}.=$_.','; 
 1241: 		}
 1242: 	    } elsif (&Apache::loncommon::keyword($_)) {
 1243: 		$ENV{'form.keywords'}.=$_.',';
 1244: 	    }
 1245: 	}
 1246: 	$ENV{'form.keywords'}=~s/\,$//;
 1247: 	unless ($ENV{'form.creationdate'}) { $ENV{'form.creationdate'}=time; }
 1248: 	$ENV{'form.lastrevisiondate'}=time;
 1249: 	if ((($style eq 'rat') && ($ENV{'form.copyright'} eq 'public')) ||
 1250: 	    (!$ENV{'form.copyright'})) { 
 1251: 	    $ENV{'form.copyright'}='default';
 1252: 	}
 1253: 	$ENV{'form.allmeta'}=&Apache::lonnet::escape($allmeta);
 1254: 	return ($scrout,0);
 1255:     }
 1256: }
 1257: 
 1258: #########################################
 1259: #########################################
 1260: 
 1261: =pod 
 1262: 
 1263: =item B<phasetwo>
 1264: 
 1265: Render second interface showing status of publication steps.
 1266: This is publication step two.
 1267: 
 1268: Parameters:
 1269: 
 1270: =over 4
 1271: 
 1272: =item I<$source>
 1273: 
 1274: =item I<$target>
 1275: 
 1276: =item I<$style>
 1277: 
 1278: =item I<$distarget>
 1279: 
 1280: =back
 1281: 
 1282: Returns:
 1283: 
 1284: =over 4
 1285: 
 1286: =item Scalar string
 1287: 
 1288: String contains status (errors and warnings) and information associated with
 1289: the server's attempts at publication.     
 1290: 
 1291: =cut
 1292: 
 1293: #'stupid emacs
 1294: #########################################
 1295: #########################################
 1296: sub phasetwo {
 1297: 
 1298:     my ($r,$source,$target,$style,$distarget,$batch)=@_;
 1299:     $source=~s/\/+/\//g;
 1300:     $target=~s/\/+/\//g;
 1301: 
 1302:     if ($target=~/\_\_\_/) {
 1303: 	$r->print(
 1304:  '<font color="red">'.&mt('Unsupported character combination').
 1305: 		  ' "<tt>___</tt>" '.&mt('in filename, FAIL').'</font>');
 1306:         return 0;
 1307:     }
 1308:     $distarget=~s/\/+/\//g;
 1309:     my $logfile;
 1310:     unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
 1311: 	$r->print(
 1312:         '<font color="red">'.
 1313: 		&mt('No write permission to user directory, FAIL').'</font>');
 1314:         return 0;
 1315:     }
 1316:     print $logfile 
 1317:         "\n================= Publish ".localtime()." Phase Two  ================\n".$ENV{'user.name'}.'@'.$ENV{'user.domain'}."\n";
 1318:     
 1319:     %metadatafields=();
 1320:     %metadatakeys=();
 1321:     
 1322:     &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'}));
 1323:     
 1324:     $metadatafields{'title'}=$ENV{'form.title'};
 1325:     $metadatafields{'author'}=$ENV{'form.author'};
 1326:     $metadatafields{'subject'}=$ENV{'form.subject'};
 1327:     $metadatafields{'notes'}=$ENV{'form.notes'};
 1328:     $metadatafields{'abstract'}=$ENV{'form.abstract'};
 1329:     $metadatafields{'mime'}=$ENV{'form.mime'};
 1330:     $metadatafields{'language'}=$ENV{'form.language'};
 1331:     $metadatafields{'creationdate'}=$ENV{'form.creationdate'};
 1332:     $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'};
 1333:     $metadatafields{'owner'}=$ENV{'form.owner'};
 1334:     $metadatafields{'copyright'}=$ENV{'form.copyright'};
 1335:     $metadatafields{'customdistributionfile'}=
 1336:                                  $ENV{'form.customdistributionfile'};
 1337:     $metadatafields{'obsolete'}=$ENV{'form.obsolete'};
 1338:     $metadatafields{'obsoletereplacement'}=
 1339: 	                        $ENV{'form.obsoletereplacement'};
 1340:     $metadatafields{'dependencies'}=$ENV{'form.dependencies'};
 1341:     
 1342:     my $allkeywords=$ENV{'form.addkey'};
 1343:     if (exists($ENV{'form.keywords'})) {
 1344:         if (ref($ENV{'form.keywords'})) {
 1345:             $allkeywords .= ','.join(',',@{$ENV{'form.keywords'}});
 1346:         } else {
 1347:             $allkeywords .= ','.$ENV{'form.keywords'};
 1348:         }
 1349:     }
 1350:     $allkeywords=~s/\W+/\,/;
 1351:     $allkeywords=~s/^\,//;
 1352:     $metadatafields{'keywords'}=$allkeywords;
 1353:     
 1354:     {
 1355:         print $logfile "\nWrite metadata file for ".$source;
 1356:         my $mfh;
 1357:         unless ($mfh=Apache::File->new('>'.$source.'.meta')) {
 1358:             return 
 1359:                 '<font color="red">'.&mt('Could not write metadata, FAIL').
 1360: 		'</font>';
 1361:         }
 1362:         foreach (sort keys %metadatafields) {
 1363:             unless ($_=~/\./) {
 1364:                 my $unikey=$_;
 1365:                 $unikey=~/^([A-Za-z]+)/;
 1366:                 my $tag=$1;
 1367:                 $tag=~tr/A-Z/a-z/;
 1368:                 print $mfh "\n\<$tag";
 1369:                 foreach (split(/\,/,$metadatakeys{$unikey})) {
 1370:                     my $value=$metadatafields{$unikey.'.'.$_};
 1371:                     $value=~s/\"/\'\'/g;
 1372:                     print $mfh ' '.$_.'="'.$value.'"';
 1373:                 }
 1374:                 print $mfh '>'.
 1375:                     &HTML::Entities::encode($metadatafields{$unikey})
 1376:                         .'</'.$tag.'>';
 1377:             }
 1378:         }
 1379:         $r->print('<p>'.&mt('Wrote Metadata').'</p>');
 1380:         print $logfile "\nWrote metadata";
 1381:     }
 1382:     
 1383: # -------------------------------- Synchronize entry with SQL metadata database
 1384: 
 1385:     $metadatafields{'url'} = $distarget;
 1386:     $metadatafields{'version'} = 'current';
 1387:     unless ($metadatafields{'copyright'} eq 'priv') {
 1388:         my ($error,$success) = &store_metadata(\%metadatafields);
 1389:         if ($success) {
 1390:             $r->print('<p>'.&mt('Synchronized SQL metadata database').'</p>');
 1391:             print $logfile "\nSynchronized SQL metadata database";
 1392:         } else {
 1393:             $r->print($error);
 1394:             print $logfile "\n".$error;
 1395:         }
 1396:     } else {
 1397:         $r->print('<p>'.
 1398: 	     &mt('Private Publication - did not synchronize database').'</p>');
 1399:         print $logfile "\nPrivate: Did not synchronize data into ".
 1400:             "SQL metadata database";
 1401:     }
 1402: # ----------------------------------------------------------- Copy old versions
 1403:    
 1404:     if (-e $target) {
 1405:         my $filename;
 1406:         my $maxversion=0;
 1407:         $target=~/(.*)\/([^\/]+)\.(\w+)$/;
 1408:         my $srcf=$2;
 1409:         my $srct=$3;
 1410:         my $srcd=$1;
 1411:         unless ($srcd=~/^\/home\/httpd\/html\/res/) {
 1412:             print $logfile "\nPANIC: Target dir is ".$srcd;
 1413:             return "<font color=\"red\">Invalid target directory, FAIL</font>";
 1414:         }
 1415:         opendir(DIR,$srcd);
 1416:         while ($filename=readdir(DIR)) {
 1417:             if (-l $srcd.'/'.$filename) {
 1418:                 unlink($srcd.'/'.$filename);
 1419:                 unlink($srcd.'/'.$filename.'.meta');
 1420:             } else {
 1421:                 if ($filename=~/\Q$srcf\E\.(\d+)\.\Q$srct\E$/) {
 1422:                     $maxversion=($1>$maxversion)?$1:$maxversion;
 1423:                 }
 1424:             }
 1425:         }
 1426:         closedir(DIR);
 1427:         $maxversion++;
 1428:         $r->print('<p>Creating old version '.$maxversion.'</p>');
 1429:         print $logfile "\nCreating old version ".$maxversion."\n";
 1430:         
 1431:         my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct;
 1432:         
 1433:         if (copy($target,$copyfile)) {
 1434: 	    print $logfile "Copied old target to ".$copyfile."\n";
 1435:             $r->print('<p>'.&mt('Copied old target file').'</p>');
 1436:         } else {
 1437: 	    print $logfile "Unable to write ".$copyfile.':'.$!."\n";
 1438:             return "<font color=\"red\">".&mt('Failed to copy old target').
 1439: 		", $!, ".&mt('FAIL')."</font>";
 1440:         }
 1441:         
 1442: # --------------------------------------------------------------- Copy Metadata
 1443: 
 1444: 	$copyfile=$copyfile.'.meta';
 1445:         
 1446:         if (copy($target.'.meta',$copyfile)) {
 1447: 	    print $logfile "Copied old target metadata to ".$copyfile."\n";
 1448:             $r->print('<p>'.&mt('Copied old metadata').'</p>')
 1449:         } else {
 1450: 	    print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n";
 1451:             if (-e $target.'.meta') {
 1452:                 return 
 1453:                     "<font color=\"red\">".
 1454: &mt('Failed to write old metadata copy').", $!, ".&mt('FAIL')."</font>";
 1455: 	    }
 1456:         }
 1457:         
 1458:         
 1459:     } else {
 1460:         $r->print('<p>'.&mt('Initial version').'</p>');
 1461:         print $logfile "\nInitial version";
 1462:     }
 1463: 
 1464: # ---------------------------------------------------------------- Write Source
 1465:     my $copyfile=$target;
 1466:     
 1467:     my @parts=split(/\//,$copyfile);
 1468:     my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
 1469:     
 1470:     my $count;
 1471:     for ($count=5;$count<$#parts;$count++) {
 1472:         $path.="/$parts[$count]";
 1473:         if ((-e $path)!=1) {
 1474:             print $logfile "\nCreating directory ".$path;
 1475:             $r->print('<p>'.&mt('Created directory').' '.$parts[$count].'</p>');
 1476:             mkdir($path,0777);
 1477:         }
 1478:     }
 1479:     
 1480:     if (copy($source,$copyfile)) {
 1481:         print $logfile "\nCopied original source to ".$copyfile."\n";
 1482:         $r->print('<p>'.&mt('Copied source file').'</p>');
 1483:     } else {
 1484:         print $logfile "\nUnable to write ".$copyfile.':'.$!."\n";
 1485:         return "<font color=\"red\">".
 1486: 	    &mt('Failed to copy source').", $!, ".&mt('FAIL')."</font>";
 1487:     }
 1488:     
 1489: # --------------------------------------------------------------- Copy Metadata
 1490: 
 1491:     $copyfile=$copyfile.'.meta';
 1492:     
 1493:     if (copy($source.'.meta',$copyfile)) {
 1494:         print $logfile "\nCopied original metadata to ".$copyfile."\n";
 1495:         $r->print('<p>'.&mt('Copied metadata').'</p>');
 1496:     } else {
 1497:         print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n";
 1498:         return 
 1499:             "<font color=\"red\">".&mt('Failed to write metadata copy').", $!, ".&mt('FAIL')."</font>";
 1500:     }
 1501:     $r->rflush;
 1502: # --------------------------------------------------- Send update notifications
 1503: 
 1504:     my @subscribed=&get_subscribed_hosts($target);
 1505:     foreach my $subhost (@subscribed) {
 1506: 	$r->print('<p>'.&mt('Notifying host').' '.$subhost.':');$r->rflush;
 1507: 	print $logfile "\nNotifying host ".$subhost.':';
 1508: 	my $reply=&Apache::lonnet::critical('update:'.$target,$subhost);
 1509: 	$r->print($reply.'</p><br />');$r->rflush;
 1510: 	print $logfile $reply;
 1511:     }
 1512:     
 1513: # ---------------------------------------- Send update notifications, meta only
 1514: 
 1515:     my @subscribedmeta=&get_subscribed_hosts("$target.meta");
 1516:     foreach my $subhost (@subscribedmeta) {
 1517: 	$r->print('<p>'.
 1518: &mt('Notifying host for metadata only').' '.$subhost.':');$r->rflush;
 1519: 	print $logfile "\nNotifying host for metadata only ".$subhost.':';
 1520: 	my $reply=&Apache::lonnet::critical('update:'.$target.'.meta',
 1521: 					    $subhost);
 1522: 	$r->print($reply.'</p><br />');$r->rflush;
 1523: 	print $logfile $reply;
 1524:     }
 1525:     
 1526: # --------------------------------------------------- Notify subscribed courses
 1527:     my %courses=&coursedependencies($target);
 1528:     my $now=time;
 1529:     foreach (keys %courses) {
 1530: 	$r->print('<p>'.&mt('Notifying course').' '.$_.':');$r->rflush;
 1531: 	print $logfile "\nNotifying host ".$_.':';
 1532:         my ($cdom,$cname)=split(/\_/,$_);
 1533: 	my $reply=&Apache::lonnet::cput
 1534:                   ('versionupdate',{$target => $now},$cdom,$cname);
 1535: 	$r->print($reply.'</p><br />');$r->rflush;
 1536: 	print $logfile $reply;
 1537:     }
 1538: # ------------------------------------------------ Provide link to new resource
 1539:     unless ($batch) {
 1540:         my $thisdistarget=$target;
 1541:         $thisdistarget=~s/^\Q$docroot\E//;
 1542:         
 1543:         my $thissrc=$source;
 1544:         $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/;
 1545:         
 1546:         my $thissrcdir=$thissrc;
 1547:         $thissrcdir=~s/\/[^\/]+$/\//;
 1548:         
 1549:         
 1550:         $r->print(
 1551:            '<hr /><a href="'.$thisdistarget.'"><font size="+2">'.
 1552:            &mt('View Published Version').'</font></a>'.
 1553:            '<p><a href="'.$thissrc.'"><font size=+2>'.
 1554: 		  &mt('Back to Source').'</font></a></p>'.
 1555:            '<p><a href="'.$thissrcdir.
 1556:                    '"><font size="+2">'.
 1557: 		  &mt('Back to Source Directory').'</font></a></p>');
 1558:     }
 1559: }
 1560: 
 1561: #########################################
 1562: 
 1563: sub batchpublish {
 1564:     my ($r,$srcfile,$targetfile)=@_;
 1565:     #publication pollutes %ENV with form.* values
 1566:     my %oldENV=%ENV;
 1567:     $srcfile=~s/\/+/\//g;
 1568:     $targetfile=~s/\/+/\//g;
 1569:     my $thisdisfn=$srcfile;
 1570:     $thisdisfn=~s/\/home\/korte\/public_html\///;
 1571:     $srcfile=~s/\/+/\//g;
 1572: 
 1573:     my $docroot=$r->dir_config('lonDocRoot');
 1574:     my $thisdistarget=$targetfile;
 1575:     $thisdistarget=~s/^\Q$docroot\E//;
 1576: 
 1577: 
 1578:     %metadatafields=();
 1579:     %metadatakeys=();
 1580:     $srcfile=~/\.(\w+)$/;
 1581:     my $thistype=$1;
 1582: 
 1583: 
 1584:     my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
 1585:      
 1586:     $r->print('<h2>'.&mt('Publishing').' <tt>'.$thisdisfn.'</tt></h2>');
 1587: 
 1588: # phase one takes
 1589: #  my ($source,$target,$style,$batch)=@_;
 1590:     my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1);
 1591:     $r->print('<p>'.$outstring.'</p>');
 1592: # phase two takes
 1593: # my ($source,$target,$style,$distarget,batch)=@_;
 1594: # $ENV{'form.allmeta'},$ENV{'form.title'},$ENV{'form.author'},...
 1595:     if (!$error) {
 1596: 	$r->print('<p>');
 1597: 	&phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1);
 1598: 	$r->print('</p>');
 1599:     }
 1600:     %ENV=%oldENV;
 1601:     return '';
 1602: }
 1603: 
 1604: #########################################
 1605: 
 1606: sub publishdirectory {
 1607:     my ($r,$fn,$thisdisfn)=@_;
 1608:     $fn=~s/\/+/\//g;
 1609:     $thisdisfn=~s/\/+/\//g;
 1610:     my $resdir=
 1611: 	$Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$cudom.'/'.$cuname.'/'.
 1612: 	$thisdisfn;
 1613:     $r->print('<h1>Directory <tt>'.$thisdisfn.'</tt></h1>'.
 1614: 	      'Target: <tt>'.$resdir.'</tt><br />');
 1615: 
 1616:     my $dirptr=16384;		# Mask indicating a directory in stat.cmode.
 1617: 
 1618:     opendir(DIR,$fn);
 1619:     my @files=sort(readdir(DIR));
 1620:     foreach my $filename (@files) {
 1621: 	my ($cdev,$cino,$cmode,$cnlink,
 1622:             $cuid,$cgid,$crdev,$csize,
 1623:             $catime,$cmtime,$cctime,
 1624:             $cblksize,$cblocks)=stat($fn.'/'.$filename);
 1625: 
 1626: 	my $extension='';
 1627: 	if ($filename=~/\.(\w+)$/) { $extension=$1; }
 1628: 	if ($cmode&$dirptr) {
 1629: 	    if (($filename!~/^\./) && ($ENV{'form.pubrec'})) {
 1630: 		&publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename);
 1631: 	    }
 1632: 	} elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') &&
 1633: 		 ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) {
 1634: # find out publication status and/or exiting metadata
 1635: 	    my $publishthis=0;
 1636: 	    if (-e $resdir.'/'.$filename) {
 1637: 	        my ($rdev,$rino,$rmode,$rnlink,
 1638: 		    $ruid,$rgid,$rrdev,$rsize,
 1639: 		    $ratime,$rmtime,$rctime,
 1640: 		    $rblksize,$rblocks)=stat($resdir.'/'.$filename);
 1641: 	        if (($rmtime<$cmtime) || ($ENV{'form.forcerepub'})) {
 1642: # previously published, modified now
 1643: 		    $publishthis=1;
 1644:                 }
 1645: 	    } else {
 1646: # never published
 1647: 		$publishthis=1;
 1648: 	    }
 1649: 	    if ($publishthis) {
 1650:                 &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename);
 1651: 	    } else {
 1652: 		$r->print('<br />Skipping '.$filename.'<br />');
 1653: 	    }
 1654: 	    $r->rflush();
 1655: 	}
 1656:     }
 1657:     closedir(DIR);
 1658: }
 1659: #########################################
 1660: 
 1661: =pod
 1662: 
 1663: =item B<handler>
 1664: 
 1665: A basic outline of the handler subroutine follows.
 1666: 
 1667: =over 4
 1668: 
 1669: =item *
 1670: 
 1671: Get query string for limited number of parameters.
 1672: 
 1673: =item *
 1674: 
 1675: Check filename.
 1676: 
 1677: =item *
 1678: 
 1679: File is there and owned, init lookup tables.
 1680: 
 1681: =item *
 1682: 
 1683: Start page output.
 1684: 
 1685: =item *
 1686: 
 1687: Evaluate individual file, and then output information.
 1688: 
 1689: =item *
 1690: 
 1691: Publishing from $thisfn to $thistarget with $thisembstyle.
 1692: 
 1693: =back
 1694: 
 1695: =cut
 1696: 
 1697: #########################################
 1698: #########################################
 1699: sub handler {
 1700:     my $r=shift;
 1701: 
 1702:     if ($r->header_only) {
 1703: 	&Apache::loncommon::content_type($r,'text/html');
 1704: 	$r->send_http_header;
 1705: 	return OK;
 1706:     }
 1707: 
 1708: # Get query string for limited number of parameters
 1709: 
 1710:     &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
 1711:                                             ['filename']);
 1712: 
 1713: # -------------------------------------------------------------- Check filename
 1714: 
 1715:     my $fn=&Apache::lonnet::unescape($ENV{'form.filename'});
 1716: 
 1717:   
 1718:     unless ($fn) { 
 1719: 	$r->log_reason($cuname.' at '.$cudom.
 1720: 		       ' trying to publish empty filename', $r->filename); 
 1721: 	return HTTP_NOT_FOUND;
 1722:     } 
 1723: 
 1724:     ($cuname,$cudom)=
 1725: 	&Apache::loncacc::constructaccess($fn,$r->dir_config('lonDefDomain'));
 1726:     unless (($cuname) && ($cudom)) {
 1727: 	$r->log_reason($cuname.' at '.$cudom.
 1728: 		       ' trying to publish file '.$ENV{'form.filename'}.
 1729: 		       ' ('.$fn.') - not authorized', 
 1730: 		       $r->filename); 
 1731: 	return HTTP_NOT_ACCEPTABLE;
 1732:     }
 1733: 
 1734:     my $home=&Apache::lonnet::homeserver($cuname,$cudom);
 1735:     my $allowed=0;
 1736:     my @ids=&Apache::lonnet::current_machine_ids();
 1737:     foreach my $id (@ids) { if ($id eq $home) { $allowed = 1; }  }
 1738:     unless ($allowed) {
 1739: 	$r->log_reason($cuname.' at '.$cudom.
 1740: 		       ' trying to publish file '.$ENV{'form.filename'}.
 1741: 		       ' ('.$fn.') - not homeserver ('.$home.')', 
 1742: 		       $r->filename); 
 1743: 	return HTTP_NOT_ACCEPTABLE;
 1744:     }
 1745: 
 1746:     $fn=~s/^http\:\/\/[^\/]+//;
 1747:     $fn=~s/^\/\~(\w+)/\/home\/$1\/public_html/;
 1748: 
 1749:     my $targetdir='';
 1750:     $docroot=$r->dir_config('lonDocRoot'); 
 1751:     if ($1 ne $cuname) {
 1752: 	$r->log_reason($cuname.' at '.$cudom.
 1753: 		       ' trying to publish unowned file '.
 1754: 		       $ENV{'form.filename'}.' ('.$fn.')', 
 1755: 		       $r->filename); 
 1756: 	return HTTP_NOT_ACCEPTABLE;
 1757:     } else {
 1758: 	$targetdir=$docroot.'/res/'.$cudom;
 1759:     }
 1760:                                  
 1761:   
 1762:     unless (-e $fn) { 
 1763: 	$r->log_reason($cuname.' at '.$cudom.
 1764: 		       ' trying to publish non-existing file '.
 1765: 		       $ENV{'form.filename'}.' ('.$fn.')', 
 1766: 		       $r->filename); 
 1767: 	return HTTP_NOT_FOUND;
 1768:     } 
 1769: 
 1770:     unless ($ENV{'form.phase'} eq 'two') {
 1771: 
 1772: # -------------------------------- File is there and owned, init lookup tables.
 1773: 
 1774: 	%addid=();
 1775: 
 1776: 	{
 1777: 	    my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab');
 1778: 	    while (<$fh>=~/(\w+)\s+(\w+)/) {
 1779: 		$addid{$1}=$2;
 1780: 	    }
 1781: 	}
 1782: 
 1783: 	%nokey=();
 1784: 
 1785: 	{
 1786: 	    my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab');
 1787: 	    while (<$fh>) {
 1788: 		my $word=$_;
 1789: 		chomp($word);
 1790: 		$nokey{$word}=1;
 1791: 	    }
 1792: 	}
 1793: 
 1794:     }
 1795: 
 1796: # ---------------------------------------------------------- Start page output.
 1797: 
 1798:     &Apache::loncommon::content_type($r,'text/html');
 1799:     $r->send_http_header;
 1800: 
 1801:     $r->print('<html><head><title>LON-CAPA Publishing</title></head>');
 1802:     $r->print(&Apache::loncommon::bodytag('Resource Publication'));
 1803: 
 1804: 
 1805:     my $thisfn=$fn;
 1806: 
 1807:     my $thistarget=$thisfn;
 1808:       
 1809:     $thistarget=~s/^\/home/$targetdir/;
 1810:     $thistarget=~s/\/public\_html//;
 1811: 
 1812:     my $thisdistarget=$thistarget;
 1813:     $thisdistarget=~s/^\Q$docroot\E//;
 1814: 
 1815:     my $thisdisfn=$thisfn;
 1816:     $thisdisfn=~s/^\/home\/\Q$cuname\E\/public_html\///;
 1817: 
 1818:     if ($fn=~/\/$/) {
 1819: # -------------------------------------------------------- This is a directory
 1820: 	&publishdirectory($r,$fn,$thisdisfn);
 1821: 	$r->print('<hr><font size="+2">'.&mt('Done').'</font><br><a href="/priv/'
 1822: 		  .$cuname.'/'.$thisdisfn
 1823: 		  .'">'.&mt('Return to Directory').'</a>');
 1824: 
 1825: 
 1826:     } else {
 1827: # ---------------------- Evaluate individual file, and then output information.
 1828: 	$thisfn=~/\.(\w+)$/;
 1829: 	my $thistype=$1;
 1830: 	my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
 1831: 	$r->print('<h2>'.&mt('Publishing').' '.
 1832: 		  &Apache::loncommon::filedescription($thistype).' <tt>');
 1833: 
 1834: 	$r->print(<<ENDCAPTION);
 1835: <a href='javascript:void(window.open("/~$cuname/$thisdisfn","cat","height=300,width=500,scrollbars=1,resizable=1,menubar=0,location=1"))'>
 1836: $thisdisfn</a>
 1837: ENDCAPTION
 1838:         $r->print('</tt></h2><b>'.&mt('Target').':</b> <tt>'.
 1839: 		  $thisdistarget.'</tt><br />');
 1840:    
 1841: 	if (($cuname ne $ENV{'user.name'})||($cudom ne $ENV{'user.domain'})) {
 1842: 	    $r->print('<h3><font color="red">'.&mt('Co-Author').': '.
 1843: 		      $cuname.&mt(' at ').$cudom.'</font></h3>');
 1844: 	}
 1845: 
 1846: 	if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') {
 1847: 	    $r->print(<<ENDDIFF);
 1848: <br />
 1849: <a href='javascript:void(window.open("/adm/diff?filename=/~$cuname/$thisdisfn&versiontwo=priv","cat","height=300,width=500,scrollbars=1,resizable=1,menubar=0,location=1"))'>
 1850: ENDDIFF
 1851:             $r->print(&mt('Diffs with Current Version').'</a><br />');
 1852: 	}
 1853:   
 1854: # ------------------ Publishing from $thisfn to $thistarget with $thisembstyle.
 1855: 
 1856: 	unless ($ENV{'form.phase'} eq 'two') {
 1857: 	    my ($outstring,$error)=&publish($thisfn,$thistarget,$thisembstyle);
 1858: 	    $r->print('<hr />'.$outstring);
 1859: 	} else {
 1860: 	    $r->print('<hr />');
 1861: 	    &phasetwo($r,$thisfn,$thistarget,$thisembstyle,$thisdistarget); 
 1862: 	}
 1863:     }
 1864:     $r->print('</body></html>');
 1865: 
 1866:     return OK;
 1867: }
 1868: 
 1869: 1;
 1870: __END__
 1871: 
 1872: =pod
 1873: 
 1874: =back
 1875: 
 1876: =back
 1877: 
 1878: =cut
 1879: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>