--- loncom/publisher/lonpublisher.pm 2005/05/30 16:56:46 1.196
+++ loncom/publisher/lonpublisher.pm 2007/07/13 20:11:27 1.227
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Publication Handler
#
-# $Id: lonpublisher.pm,v 1.196 2005/05/30 16:56:46 www Exp $
+# $Id: lonpublisher.pm,v 1.227 2007/07/13 20:11:27 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -129,6 +129,8 @@ use Apache::loncfile;
use LONCAPA::lonmetadata;
use Apache::lonmsg;
use vars qw(%metadatafields %metadatakeys);
+use LONCAPA qw(:DEFAULT :match);
+
my %addid;
my %nokey;
@@ -181,17 +183,18 @@ sub metaeval {
if ($token->[0] eq 'S') {
my $entry=$token->[1];
my $unikey=$entry;
+ next if ($entry =~ m/^(?:parameter|stores)_/);
if (defined($token->[2]->{'package'})) {
- $unikey.='_package_'.$token->[2]->{'package'};
+ $unikey.="\0package\0".$token->[2]->{'package'};
}
if (defined($token->[2]->{'part'})) {
- $unikey.='_'.$token->[2]->{'part'};
+ $unikey.="\0".$token->[2]->{'part'};
}
if (defined($token->[2]->{'id'})) {
- $unikey.='_'.$token->[2]->{'id'};
+ $unikey.="\0".$token->[2]->{'id'};
}
if (defined($token->[2]->{'name'})) {
- $unikey.='_'.$token->[2]->{'name'};
+ $unikey.="\0".$token->[2]->{'name'};
}
foreach (@{$token->[3]}) {
$metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};
@@ -278,9 +281,8 @@ sub metaread {
sub coursedependencies {
my $url=&Apache::lonnet::declutter(shift);
$url=~s/\.meta$//;
- my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//);
- my $regexp=$url;
- $regexp=~s/(\W)/\\$1/g;
+ my ($adomain,$aauthor)=($url=~ m{^($match_domain)/($match_username)/});
+ my $regexp=quotemeta($url);
$regexp='___'.$regexp.'___course';
my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain,
$aauthor,$regexp);
@@ -355,7 +357,8 @@ sub hiddenfield {
sub checkbox {
my ($name,$text)=@_;
- return "\n '.&mt('New parameters or stored values').
+ $scrout.=' '.&mt('New parameters or saved values').
': '.$chparms.' '.&mt('Obsolete parameters or stored values').': '.
- $chparms.' '.
- &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').' '.&mt('Obsolete parameters or saved values').': '.
+ $chparms.' '.
+ &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').' '.($env{'form.makeobsolete'}?'':'').' $uctitle:".
+ "\n'.
+ $intr_scrout.='/ > '.&mt('Warning: It can take up to 1 hour for rights changes to fully propagate.').' '.&mt('Copied old target file').' '.&mt('Copied source file').' '.&mt('Copied metadata').'
".&mt($text);
+ return "\n
";
}
sub selectbox {
@@ -406,15 +409,14 @@ sub urlfixup {
if ($url =~ /^mailto:/i) { return $url; }
#internal document links need no fixing
if ($url =~ /^\#/) { return $url; }
- my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/);
- foreach (values %Apache::lonnet::hostname) {
- if ($_ eq $host) {
- $url=~s/^http\:\/\///;
- $url=~s/^$host//;
- }
+ my ($host)=($url=~m{(?:(?:http|https|ftp)://)*([^/]+)});
+ my @lonids = &Apache::lonnet::machine_ids($host);
+ if (@lonids) {
+ $url=~s{^(?:http|https|ftp)://}{};
+ $url=~s/^\Q$host\E//;
}
- if ($url=~/^http\:\/\//) { return $url; }
- $url=~s/\~$cuname/res\/$cudom\/$cuname/;
+ if ($url=~m{^(?:http|https|ftp)://}) { return $url; }
+ $url=~s{\Q~$cuname\E}{res/$cudom/$cuname};
return $url;
}
@@ -465,11 +467,11 @@ sub set_allow {
}
if (($newurl !~ /^javascript:/i) &&
($newurl !~ /^mailto:/i) &&
- ($newurl !~ /^http:/i) &&
+ ($newurl !~ /^(?:http|https|ftp):/i) &&
($newurl !~ /^\#/)) {
$$allow{&absoluteurl($newurl,$target)}=1;
}
- return $return_url
+ return $return_url;
}
#########################################
@@ -492,11 +494,15 @@ sub get_subscribed_hosts {
$target=~/(.*)\/([^\/]+)$/;
my $srcf=$2;
opendir(DIR,$1);
+ # cycle through listed files, subscriptions used to exist
+ # as "filename.lonid"
while ($filename=readdir(DIR)) {
- if ($filename=~/\Q$srcf\E\.(\w+)$/) {
+ if ($filename=~/\Q$srcf\E\.($match_lonid)$/) {
my $subhost=$1;
- if (($subhost ne 'meta' && $subhost ne 'subscription' &&
- $subhost ne 'tmp') &&
+ if (($subhost ne 'meta'
+ && $subhost ne 'subscription'
+ && $subhost ne 'meta.subscription'
+ && $subhost ne 'tmp') &&
($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) {
push(@subscribed,$subhost);
}
@@ -505,19 +511,13 @@ sub get_subscribed_hosts {
closedir(DIR);
my $sh;
if ( $sh=Apache::File->new("$target.subscription") ) {
- &Apache::lonnet::logthis("opened $target.subscription");
while (my $subline=<$sh>) {
- &Apache::lonnet::logthis("Trying $subline");
- if ($subline =~ /(^\w+):/) {
+ if ($subline =~ /^($match_lonid):/) {
if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) {
push(@subscribed,$1);
}
- } else {
- &Apache::lonnet::logthis("No Match for $subline");
}
}
- } else {
- &Apache::lonnet::logthis("Unable to open $target.subscription");
}
return @subscribed;
}
@@ -547,6 +547,7 @@ sub get_max_ids_indices {
my %duplicatedids;
my $parser=HTML::LCParser->new($content);
+ $parser->xml_mode(1);
my $token;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
@@ -653,7 +654,7 @@ sub fix_ids_and_indices {
join(', ',@duplicatedids));
if ($duplicateids) {
print $logfile "Duplicate ID(s) exist, ".join(', ',@duplicatedids)."\n";
- my $outstring=''.&mt('Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are').': '.join(', ',@duplicatedids).'';
+ my $outstring=''.&mt('Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are').': '.join(', ',@duplicatedids).'';
return ($outstring,1);
}
if ($needsfixup) {
@@ -676,6 +677,7 @@ sub fix_ids_and_indices {
$allow{$token->[2]->{'src'}}=1;
next;
}
+ if ($lctag eq 'base') { next; }
my %parms=%{$token->[2]};
$counter=$addid{$tag};
if (!$counter) { $counter=$addid{$lctag}; }
@@ -685,7 +687,9 @@ sub fix_ids_and_indices {
$parms{'id'}!~/^\s*$/) {
$maxid++;
$parms{'id'}=$maxid;
- print $logfile 'ID: '.$tag.':'.$maxid."\n";
+ print $logfile 'ID(new) : '.$tag.':'.$maxid."\n";
+ } else {
+ print $logfile 'ID(kept): '.$tag.':'.$parms{'id'}."\n";
}
} elsif ($counter eq 'index') {
unless (defined($parms{'index'}) &&
@@ -696,12 +700,14 @@ sub fix_ids_and_indices {
}
}
}
- foreach my $type ('src','href','background','bgimg') {
- foreach my $key (keys(%parms)) {
- if ($key =~ /^$type$/i) {
- $parms{$key}=&set_allow(\%allow,$logfile,
- $target,$tag,
- $parms{$key});
+ unless ($parms{'type'} eq 'zombie') {
+ foreach my $type ('src','href','background','bgimg') {
+ foreach my $key (keys(%parms)) {
+ if ($key =~ /^$type$/i) {
+ $parms{$key}=&set_allow(\%allow,$logfile,
+ $target,$tag,
+ $parms{$key});
+ }
}
}
}
@@ -712,6 +718,7 @@ sub fix_ids_and_indices {
($lctag eq 'image')) {
my $next_token=$parser[-1]->get_token();
if ($next_token->[0] eq 'T') {
+ $next_token->[1] =~ s/[\n\r\f]+//g;
$next_token->[1]=&set_allow(\%allow,$logfile,
$target,$tag,
$next_token->[1]);
@@ -818,15 +825,15 @@ sub store_metadata {
# Determine if the table exists
my $status = &Apache::lonmysql::check_table('metadata');
if (! defined($status)) {
- $error='WARNING: Cannot connect to '.
- 'database!';
+ $error='WARNING: Cannot connect to '.
+ 'database!';
&Apache::lonnet::logthis($error);
return ($error,undef);
}
if ($status == 0) {
# It would be nice to actually create the table....
- $error ='WARNING: The metadata table does not '.
- 'exist in the LON-CAPA database.';
+ $error ='WARNING: The metadata table does not '.
+ 'exist in the LON-CAPA database.';
&Apache::lonnet::logthis($error);
return ($error,undef);
}
@@ -837,17 +844,17 @@ sub store_metadata {
$status=&LONCAPA::lonmetadata::delete_metadata($dbh,undef,
$metadata{'url'});
} else {
- $status = &LONCAPA::lonmetadata::update_metadata($dbh,undef,
+ $status = &LONCAPA::lonmetadata::update_metadata($dbh,undef,undef,
\%metadata);
}
if (defined($status) && $status ne '') {
- $error='Error occured storing new values in '.
- 'metadata table in LON-CAPA database';
+ $error='Error occured saving new values in '.
+ 'metadata table in LON-CAPA database';
&Apache::lonnet::logthis($error);
&Apache::lonnet::logthis($status);
return ($error,undef);
}
- return (undef,$status);
+ return (undef,'success');
}
@@ -864,9 +871,9 @@ sub checkonthis {
if (($errorcount) || ($warningcount)) {
$r->print('
'.$uri.': ');
if ($errorcount) {
- $r->print(''.
+ $r->print('
'.
$errorcount.' '.
- &mt('error(s)').' ');
+ &mt('error(s)').' ');
}
if ($warningcount) {
$r->print(''.
@@ -930,10 +937,10 @@ sub publish {
my %allow=();
unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
- return (''.&mt('No write permission to user directory, FAIL').'',1);
+ return (''.&mt('No write permission to user directory, FAIL').'',1);
}
print $logfile
-"\n\n================= Publish ".localtime()." Phase One ================\n".$env{'user.name'}.'@'.$env{'user.domain'}."\n";
+"\n\n================= Publish ".localtime()." Phase One ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n";
if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) {
# ------------------------------------------------------- This needs processing
@@ -944,7 +951,7 @@ sub publish {
print $logfile "Copied original file to ".$copyfile."\n";
} else {
print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";
- return ("Failed to write backup copy, $!,FAIL",1);
+ return ("Failed to write backup copy, $!,FAIL",1);
}
# ------------------------------------------------------------- IDs and indices
@@ -972,13 +979,13 @@ sub publish {
if (
&Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
$thisdep.'.meta') eq '-1') {
- $scrout.= ' - '.&mt('Currently not available').
- '';
+ $scrout.= ' - '.&mt('Currently not available').
+ '';
} else {
my %temphash=(&Apache::lonnet::declutter($target).'___'.
&Apache::lonnet::declutter($thisdep).'___usage'
=> time);
- $thisdep=~/^\/res\/(\w+)\/(\w+)\//;
+ $thisdep=~m{^/res/($match_domain)/($match_username)/};
if ((defined($1)) && (defined($2))) {
&Apache::lonnet::put('nohist_resevaldata',\%temphash,
$1,$2);
@@ -994,9 +1001,9 @@ sub publish {
my $org;
unless ($org=Apache::File->new('>'.$source)) {
print $logfile "No write permit to $source\n";
- return (''.&mt('No write permission to').
+ return (''.&mt('No write permission to').
' '.$source.
- ', '.&mt('FAIL').'',1);
+ ', '.&mt('FAIL').'',1);
}
print($org $outstring);
}
@@ -1027,7 +1034,7 @@ sub publish {
$env{'environment.generation'};
$metadatafields{'author'}=~s/\s+/ /g;
$metadatafields{'author'}=~s/\s+$//;
- $metadatafields{'owner'}=$cuname.'@'.$cudom;
+ $metadatafields{'owner'}=$cuname.':'.$cudom;
# ------------------------------------------------ Check out directory hierachy
@@ -1092,14 +1099,16 @@ sub publish {
if (($_=~/^parameter/) || ($_=~/^stores/)) {
unless ($_=~/\.\w+$/) {
unless ($oldparmstores{$_}) {
- print $logfile 'New: '.$_."\n";
- $chparms.=$_.' ';
+ my $disp_key = $_;
+ $disp_key =~ tr/\0/_/;
+ print $logfile ('New: '.$disp_key."\n");
+ $chparms .= $disp_key.' ';
}
}
}
}
if ($chparms) {
- $scrout.='
'.&mt('Warning!').
- '
';
+ $scrout.=''.&mt('Warning!').
+ '
';
}
# ------------------------------------------------------- Now have all metadata
@@ -1162,7 +1173,7 @@ sub publish {
'
'.&mt('Done').'
'; + $r->print(''.&mt('Done').'
'); + return 1; } # =============================================================== Notifications @@ -1764,7 +1796,7 @@ sub publishdirectory { &hiddenfield('filename',$env{'form.filename'}). &checkbox('pubrec','include subdirectories'). &checkbox('forcerepub','force republication of previously published files'). - &checkbox('forceobsolete','make file(s) obsolete'). + &checkbox('obsolete','make file(s) obsolete'). &checkbox('forceoverride','force directory level catalog information over existing'). ''.&mt('Copied source file').'
'); } else { - return "". - &mt('Failed to copy source').", $!, ".&mt('FAIL').""; + return "". + &mt('Failed to copy source').", $!, ".&mt('FAIL').""; } # --------------------------------------------------- Send update notifications @@ -1865,7 +1902,7 @@ sub defaultmetapublish { my $link=$fn; $link=~s/^\/home\/$cuname\/public_html\//\/priv\/$cuname\//; $r->print("".&mt('Back to Catalog Information').''); - $r->print('