version 1.289, 2014/01/15 18:49:56
|
version 1.294, 2014/12/12 18:27:34
|
Line 200 sub metaeval {
|
Line 200 sub metaeval {
|
if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
$unikey.="\0".$token->[2]->{'name'}; |
$unikey.="\0".$token->[2]->{'name'}; |
} |
} |
foreach (@{$token->[3]}) { |
foreach my $item (@{$token->[3]}) { |
$metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; |
$metadatafields{$unikey.'.'.$item}=$token->[2]->{$item}; |
if ($metadatakeys{$unikey}) { |
if ($metadatakeys{$unikey}) { |
$metadatakeys{$unikey}.=','.$_; |
$metadatakeys{$unikey}.=','.$item; |
} else { |
} else { |
$metadatakeys{$unikey}=$_; |
$metadatakeys{$unikey}=$item; |
} |
} |
} |
} |
my $newentry=$parser->get_text('/'.$entry); |
my $newentry=$parser->get_text('/'.$entry); |
Line 293 sub coursedependencies {
|
Line 293 sub coursedependencies {
|
my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain, |
my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain, |
$aauthor,$regexp); |
$aauthor,$regexp); |
my %courses=(); |
my %courses=(); |
foreach (keys %evaldata) { |
foreach my $item (keys(%evaldata)) { |
if ($_=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) { |
if ($item=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) { |
$courses{$1}=1; |
$courses{$1}=1; |
} |
} |
} |
} |
Line 382 sub selectbox {
|
Line 382 sub selectbox {
|
} |
} |
my $selout="\n".&Apache::lonhtmlcommon::row_title($title) |
my $selout="\n".&Apache::lonhtmlcommon::row_title($title) |
.'<select name="'.$name.'">'; |
.'<select name="'.$name.'">'; |
foreach (@idlist) { |
foreach my $id (@idlist) { |
$selout.='<option value="'.$_.'"'; |
$selout.='<option value="'.$id.'"'; |
if ($_ eq $value) { |
if ($id eq $value) { |
$selout.=' selected="selected"'; |
$selout.=' selected="selected"'; |
} |
} |
$selout.='>'.&{$functionref}($_).'</option>'; |
$selout.='>'.&{$functionref}($id).'</option>'; |
} |
} |
$selout.='</select>'.&Apache::lonhtmlcommon::row_closure(); |
$selout.='</select>'.&Apache::lonhtmlcommon::row_closure(); |
return $selout; |
return $selout; |
Line 468 Currently undocumented
|
Line 468 Currently undocumented
|
######################################### |
######################################### |
######################################### |
######################################### |
sub set_allow { |
sub set_allow { |
my ($allow,$logfile,$target,$tag,$oldurl)=@_; |
my ($allow,$logfile,$target,$tag,$oldurl,$type)=@_; |
my $newurl=&urlfixup($oldurl,$target); |
my $newurl=&urlfixup($oldurl,$target); |
my $return_url=$oldurl; |
my $return_url=$oldurl; |
print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; |
print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; |
Line 480 sub set_allow {
|
Line 480 sub set_allow {
|
($newurl !~ /^mailto:/i) && |
($newurl !~ /^mailto:/i) && |
($newurl !~ /^(?:http|https|ftp):/i) && |
($newurl !~ /^(?:http|https|ftp):/i) && |
($newurl !~ /^\#/)) { |
($newurl !~ /^\#/)) { |
|
if (($type eq 'src') || ($type eq 'href')) { |
|
if ($newurl =~ /^([^?]+)\?[^?]*$/) { |
|
$newurl = $1; |
|
} |
|
} |
$$allow{&absoluteurl($newurl,$target)}=1; |
$$allow{&absoluteurl($newurl,$target)}=1; |
} |
} |
return $return_url; |
return $return_url; |
Line 721 sub fix_ids_and_indices {
|
Line 726 sub fix_ids_and_indices {
|
foreach my $type ('src','href','background','bgimg') { |
foreach my $type ('src','href','background','bgimg') { |
foreach my $key (keys(%parms)) { |
foreach my $key (keys(%parms)) { |
if ($key =~ /^$type$/i) { |
if ($key =~ /^$type$/i) { |
|
next if (($lctag eq 'img') && ($type eq 'src') && |
|
($parms{$key} =~ m{^data\:image/gif;base64,})); |
$parms{$key}=&set_allow(\%allow,$logfile, |
$parms{$key}=&set_allow(\%allow,$logfile, |
$target,$tag, |
$target,$tag, |
$parms{$key}); |
$parms{$key},$type); |
} |
} |
} |
} |
} |
} |
Line 780 sub fix_ids_and_indices {
|
Line 787 sub fix_ids_and_indices {
|
} |
} |
my $newparmstring=''; |
my $newparmstring=''; |
my $endtag=''; |
my $endtag=''; |
foreach (keys %parms) { |
foreach my $parkey (keys(%parms)) { |
if ($_ eq '/') { |
if ($parkey eq '/') { |
$endtag=' /'; |
$endtag=' /'; |
} else { |
} else { |
my $quote=($parms{$_}=~/\"/?"'":'"'); |
my $quote=($parms{$parkey}=~/\"/?"'":'"'); |
$newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; |
$newparmstring.=' '.$parkey.'='.$quote.$parms{$parkey}.$quote; |
} |
} |
} |
} |
if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } |
if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } |
Line 818 sub fix_ids_and_indices {
|
Line 825 sub fix_ids_and_indices {
|
# |
# |
my $spritesheet = $1.'express_show/spritesheet.png'; |
my $spritesheet = $1.'express_show/spritesheet.png'; |
$allow{&absoluteurl($spritesheet,$target)}=1; |
$allow{&absoluteurl($spritesheet,$target)}=1; |
|
|
|
# |
|
# Camtasia 8.4: skins/express_show/spritesheet.min.css needed, and included in zip archive. |
|
# Not referenced directly in <main>.html or <main>_player.html files, |
|
# so add this file to %allow (where <main> is name user gave to file/archive). |
|
# |
|
my $spritecss = $1.'express_show/spritesheet.min.css'; |
|
$allow{&absoluteurl($spritecss,$target)}=1; |
} |
} |
} elsif ($srctype eq 'PosterImageSrc') { |
} elsif ($srctype eq 'PosterImageSrc') { |
if ($url =~ m{^(.+)_First_Frame\.png$}) { |
if ($url =~ m{^(.+)_First_Frame\.png$}) { |
Line 836 sub fix_ids_and_indices {
|
Line 851 sub fix_ids_and_indices {
|
} |
} |
} |
} |
} |
} |
$outstring .= $script |
if ($script =~ m{\.addMediaSrc\((["'])((?!\1).+)\1\);}) { |
|
my $src = $2; |
|
if ($src) { |
|
my $url = &urlfixup($src); |
|
unless ($url=~m{^(?:http|https|ftp)://}) { |
|
$allow{&absoluteurl($url,$target)}=1; |
|
} |
|
} |
|
} |
|
if ($script =~ /\(document,\s*(['"])script\1,\s*\[([^\]]+)\]\);/s) { |
|
my $scriptslist = $2; |
|
my @srcs = split(/\s*,\s*/,$scriptslist); |
|
foreach my $src (@srcs) { |
|
if ($src =~ /(["'])(?:(?!\1).)+\.js\1/) { |
|
my $quote = $1; |
|
my ($url) = ($src =~ m/\Q$quote\E([^$quote]+)\Q$quote\E/); |
|
$url = &urlfixup($url); |
|
unless ($url=~m{^(?:http|https|ftp)://}) { |
|
$allow{&absoluteurl($url,$target)}=1; |
|
} |
|
} |
|
} |
|
} |
|
if ($script =~ m{loadScript\(\s*(['"])((?:(?!\1).)+\.js)\1,\s*function}is) { |
|
my $src = $2; |
|
if ($src) { |
|
my $url = &urlfixup($src); |
|
unless ($url=~m{^(?:http|https|ftp)://}) { |
|
$allow{&absoluteurl($url,$target)}=1; |
|
} |
|
} |
|
} |
|
$outstring .= $script; |
} |
} |
} |
} |
} elsif ($token->[0] eq 'E') { |
} elsif ($token->[0] eq 'E') { |
Line 1150 sub publish {
|
Line 1197 sub publish {
|
|
|
# ------------------- Clear out parameters and stores (there should not be any) |
# ------------------- Clear out parameters and stores (there should not be any) |
|
|
foreach (keys %metadatafields) { |
foreach my $field (keys(%metadatafields)) { |
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
if (($field=~/^parameter/) || ($field=~/^stores/)) { |
delete $metadatafields{$_}; |
delete $metadatafields{$field}; |
} |
} |
} |
} |
|
|
Line 1161 sub publish {
|
Line 1208 sub publish {
|
|
|
$scrout.=&metaread($logfile,$source.'.meta'); |
$scrout.=&metaread($logfile,$source.'.meta'); |
|
|
foreach (keys %metadatafields) { |
foreach my $field (keys(%metadatafields)) { |
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
if (($field=~/^parameter/) || ($field=~/^stores/)) { |
$oldparmstores{$_}=1; |
$oldparmstores{$field}=1; |
delete $metadatafields{$_}; |
delete $metadatafields{$field}; |
} |
} |
} |
} |
# ------------------------------------------------------------- Save some stuff |
# ------------------------------------------------------------- Save some stuff |
my %savemeta=(); |
my %savemeta=(); |
foreach ('title') { |
if ($metadatafields{'title'}) { $savemeta{'title'}=$metadatafields{'title'}; } |
if ($metadatafields{$_}) { $savemeta{$_}=$metadatafields{$_}; } |
|
} |
|
# ------------------------------------------ See if anything new in file itself |
# ------------------------------------------ See if anything new in file itself |
|
|
$allmeta=&parseformeta($source,$style); |
$allmeta=&parseformeta($source,$style); |
# ----------------------------------------------------------- Restore the stuff |
# ----------------------------------------------------------- Restore the stuff |
foreach (keys %savemeta) { |
foreach my $item (keys(%savemeta)) { |
$metadatafields{$_}=$savemeta{$_}; |
$metadatafields{$item}=$savemeta{$item}; |
} |
} |
} |
} |
|
|
Line 1185 sub publish {
|
Line 1230 sub publish {
|
# ---------------- Find and document discrepancies in the parameters and stores |
# ---------------- Find and document discrepancies in the parameters and stores |
|
|
my $chparms=''; |
my $chparms=''; |
foreach (sort keys %metadatafields) { |
foreach my $field (sort(keys(%metadatafields))) { |
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
if (($field=~/^parameter/) || ($field=~/^stores/)) { |
unless ($_=~/\.\w+$/) { |
unless ($field=~/\.\w+$/) { |
unless ($oldparmstores{$_}) { |
unless ($oldparmstores{$field}) { |
my $disp_key = $_; |
my $disp_key = $field; |
$disp_key =~ tr/\0/_/; |
$disp_key =~ tr/\0/_/; |
print $logfile ('New: '.$disp_key."\n"); |
print $logfile ('New: '.$disp_key."\n"); |
$chparms .= $disp_key.' '; |
$chparms .= $disp_key.' '; |
Line 1203 sub publish {
|
Line 1248 sub publish {
|
} |
} |
|
|
$chparms=''; |
$chparms=''; |
foreach (sort keys %oldparmstores) { |
foreach my $olditem (sort(keys(%oldparmstores))) { |
if (($_=~/^parameter/) || ($_=~/^stores/)) { |
if (($olditem=~/^parameter/) || ($olditem=~/^stores/)) { |
unless (($metadatafields{$_.'.name'}) || |
unless (($metadatafields{$olditem.'.name'}) || |
($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { |
($metadatafields{$olditem.'.package'}) || ($olditem=~/\.\w+$/)) { |
my $disp_key = $_; |
my $disp_key = $olditem; |
$disp_key =~ tr/\0/_/; |
$disp_key =~ tr/\0/_/; |
print $logfile ('Obsolete: '.$disp_key."\n"); |
print $logfile ('Obsolete: '.$disp_key."\n"); |
$chparms.=$disp_key.' '; |
$chparms.=$disp_key.' '; |
Line 1284 sub publish {
|
Line 1329 sub publish {
|
&hiddenfield('phase','two'). |
&hiddenfield('phase','two'). |
&hiddenfield('filename',$env{'form.filename'}). |
&hiddenfield('filename',$env{'form.filename'}). |
&hiddenfield('allmeta',&escape($allmeta)). |
&hiddenfield('allmeta',&escape($allmeta)). |
&hiddenfield('dependencies',join(',',keys %allow)); |
&hiddenfield('dependencies',join(',',keys(%allow))); |
unless ($env{'form.makeobsolete'}) { |
unless ($env{'form.makeobsolete'}) { |
$intr_scrout.= |
$intr_scrout.= |
&textfield('Title','title',$metadatafields{'title'}). |
&textfield('Title','title',$metadatafields{'title'}). |
Line 1645 sub phasetwo {
|
Line 1690 sub phasetwo {
|
'</span>'); |
'</span>'); |
return 0; |
return 0; |
} |
} |
foreach (sort keys %metadatafields) { |
foreach my $field (sort(keys(%metadatafields))) { |
unless ($_=~/\./) { |
unless ($field=~/\./) { |
my $unikey=$_; |
my $unikey=$field; |
$unikey=~/^([A-Za-z]+)/; |
$unikey=~/^([A-Za-z]+)/; |
my $tag=$1; |
my $tag=$1; |
$tag=~tr/A-Z/a-z/; |
$tag=~tr/A-Z/a-z/; |
print $mfh "\n\<$tag"; |
print $mfh "\n\<$tag"; |
foreach (split(/\,/,$metadatakeys{$unikey})) { |
foreach my $item (split(/\,/,$metadatakeys{$unikey})) { |
my $value=$metadatafields{$unikey.'.'.$_}; |
my $value=$metadatafields{$unikey.'.'.$item}; |
$value=~s/\"/\'\'/g; |
$value=~s/\"/\'\'/g; |
print $mfh ' '.$_.'="'.$value.'"'; |
print $mfh ' '.$item.'="'.$value.'"'; |
} |
} |
print $mfh '>'. |
print $mfh '>'. |
&HTML::Entities::encode($metadatafields{$unikey},'<>&"') |
&HTML::Entities::encode($metadatafields{$unikey},'<>&"') |
Line 1861 sub notify {
|
Line 1906 sub notify {
|
# --------------------------------------------------- Notify subscribed courses |
# --------------------------------------------------- Notify subscribed courses |
my %courses=&coursedependencies($target); |
my %courses=&coursedependencies($target); |
my $now=time; |
my $now=time; |
foreach (keys %courses) { |
foreach my $course (keys(%courses)) { |
print $logfile "\nNotifying course ".$_.':'; |
print $logfile "\nNotifying course ".$course.':'; |
my ($cdom,$cname)=split(/\_/,$_); |
my ($cdom,$cname)=split(/\_/,$course); |
my $reply=&Apache::lonnet::cput |
my $reply=&Apache::lonnet::cput |
('versionupdate',{$target => $now},$cdom,$cname); |
('versionupdate',{$target => $now},$cdom,$cname); |
print $logfile $reply; |
print $logfile $reply; |