version 1.1172.2.93.4.9, 2018/04/06 18:20:30
|
version 1.1172.2.96, 2018/09/02 23:22:47
|
Line 695 sub appenv {
|
Line 695 sub appenv {
|
$env{$key}=$newenv->{$key}; |
$env{$key}=$newenv->{$key}; |
} |
} |
} |
} |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
my $lonids = $perlvar{'lonIDsDir'}; |
if ($opened |
if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { |
&& &timed_flock($env_file,LOCK_EX) |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
&& |
if ($opened |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
&& &timed_flock($env_file,LOCK_EX) |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
&& |
while (my ($key,$value) = each(%{$newenv})) { |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
$disk_env{$key} = $value; |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
} |
while (my ($key,$value) = each(%{$newenv})) { |
untie(%disk_env); |
$disk_env{$key} = $value; |
|
} |
|
untie(%disk_env); |
|
} |
} |
} |
} |
} |
return 'ok'; |
return 'ok'; |
Line 1697 sub get_dom {
|
Line 1700 sub get_dom {
|
} |
} |
} |
} |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
my $rep; |
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
if ($namespace =~ /^enc/) { |
|
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
|
} else { |
|
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
|
} |
|
my %returnhash; |
my %returnhash; |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
return %returnhash; |
return %returnhash; |
Line 1746 sub put_dom {
|
Line 1744 sub put_dom {
|
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
if ($namespace =~ /^enc/) { |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
|
} else { |
|
return &reply("putdom:$udom:$namespace:$items",$uhome); |
|
} |
|
} else { |
} else { |
&logthis("put_dom failed - no homeserver and/or domain"); |
&logthis("put_dom failed - no homeserver and/or domain"); |
} |
} |
Line 1841 sub inst_directory_query {
|
Line 1835 sub inst_directory_query {
|
my $homeserver = &domain($udom,'primary'); |
my $homeserver = &domain($udom,'primary'); |
my $outcome; |
my $outcome; |
if ($homeserver ne '') { |
if ($homeserver ne '') { |
unless ($homeserver eq $perlvar{'lonHostID'}) { |
|
if ($srch->{'srchby'} eq 'email') { |
|
my $lcrev = &get_server_loncaparev(undef,$homeserver); |
|
my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/); |
|
if (($major eq '' && $minor eq '') || ($major < 2) || |
|
(($major == 2) && ($minor < 11)) || |
|
(($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/))) { |
|
return; |
|
} |
|
} |
|
} |
|
my $queryid=&reply("querysend:instdirsearch:". |
my $queryid=&reply("querysend:instdirsearch:". |
&escape($srch->{'srchby'}).':'. |
&escape($srch->{'srchby'}).':'. |
&escape($srch->{'srchterm'}).':'. |
&escape($srch->{'srchterm'}).':'. |
Line 1893 sub usersearch {
|
Line 1876 sub usersearch {
|
my $query = 'usersearch'; |
my $query = 'usersearch'; |
foreach my $tryserver (keys(%libserv)) { |
foreach my $tryserver (keys(%libserv)) { |
if (&host_domain($tryserver) eq $dom) { |
if (&host_domain($tryserver) eq $dom) { |
unless ($tryserver eq $perlvar{'lonHostID'}) { |
|
if ($srch->{'srchby'} eq 'email') { |
|
my $lcrev = &get_server_loncaparev(undef,$tryserver); |
|
my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/); |
|
next if (($major eq '' && $minor eq '') || ($major < 2) || |
|
(($major == 2) && ($minor < 11)) || |
|
(($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/))); |
|
} |
|
} |
|
my $host=&hostname($tryserver); |
my $host=&hostname($tryserver); |
my $queryid= |
my $queryid= |
&reply("querysend:".&escape($query).':'. |
&reply("querysend:".&escape($query).':'. |
Line 2282 sub get_domain_defaults {
|
Line 2256 sub get_domain_defaults {
|
return %domdefaults; |
return %domdefaults; |
} |
} |
|
|
sub course_portal_url { |
|
my ($cnum,$cdom) = @_; |
|
my $chome = &homeserver($cnum,$cdom); |
|
my $hostname = &hostname($chome); |
|
my $protocol = $protocol{$chome}; |
|
$protocol = 'http' if ($protocol ne 'https'); |
|
my %domdefaults = &get_domain_defaults($cdom); |
|
my $firsturl; |
|
if ($domdefaults{'portal_def'}) { |
|
$firsturl = $domdefaults{'portal_def'}; |
|
} else { |
|
$firsturl = $protocol.'://'.$hostname; |
|
} |
|
return $firsturl; |
|
} |
|
|
|
# --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
|
|
sub assign_access_key { |
sub assign_access_key { |
Line 3058 sub can_edit_resource {
|
Line 3016 sub can_edit_resource {
|
$forceedit = 1; |
$forceedit = 1; |
} |
} |
$cfile = $resurl; |
$cfile = $resurl; |
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
|
$incourse = 1; |
|
if ($env{'form.forceedit'}) { |
|
$forceview = 1; |
|
} else { |
|
$forceedit = 1; |
|
} |
|
$cfile = $resurl; |
|
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
$incourse = 1; |
$incourse = 1; |
if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
Line 3090 sub can_edit_resource {
|
Line 3040 sub can_edit_resource {
|
$forceedit = 1; |
$forceedit = 1; |
} |
} |
$cfile = $resurl; |
$cfile = $resurl; |
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
|
$incourse = 1; |
|
if ($env{'form.forceedit'}) { |
|
$forceview = 1; |
|
} else { |
|
$forceedit = 1; |
|
} |
|
$cfile = $resurl; |
|
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { |
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { |
$incourse = 1; |
$incourse = 1; |
$forceview = 1; |
$forceview = 1; |
Line 3107 sub can_edit_resource {
|
Line 3049 sub can_edit_resource {
|
$cfile = &clutter($res); |
$cfile = &clutter($res); |
} else { |
} else { |
$cfile = $env{'form.suppurl'}; |
$cfile = $env{'form.suppurl'}; |
my $escfile = &unescape($cfile); |
$cfile =~ s{^http://}{}; |
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
$cfile = '/adm/wrapper/ext/'.$cfile; |
$cfile = '/adm/wrapper'.$escfile; |
|
} else { |
|
$escfile =~ s{^http://}{}; |
|
$cfile = &escape("/adm/wrapper/ext/$escfile"); |
|
} |
|
} |
} |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
Line 3448 sub userfileupload {
|
Line 3385 sub userfileupload {
|
} else { |
} else { |
$docudom = $env{'user.domain'}; |
$docudom = $env{'user.domain'}; |
} |
} |
if ($destuname =~ /^$match_username$/) { |
if ($destuname =~ /^$match_username$/) { |
$docuname = $destuname; |
$docuname = $destuname; |
} else { |
} else { |
$docuname = $env{'user.name'}; |
$docuname = $env{'user.name'}; |
Line 4828 my %cachedtimes=();
|
Line 4765 my %cachedtimes=();
|
my $cachedtime=''; |
my $cachedtime=''; |
|
|
sub load_all_first_access { |
sub load_all_first_access { |
my ($uname,$udom,$ignorecache)=@_; |
my ($uname,$udom)=@_; |
if (($cachedkey eq $uname.':'.$udom) && |
if (($cachedkey eq $uname.':'.$udom) && |
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && |
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) { |
(!$ignorecache)) { |
|
return; |
return; |
} |
} |
$cachedtime=time; |
$cachedtime=time; |
Line 4840 sub load_all_first_access {
|
Line 4776 sub load_all_first_access {
|
} |
} |
|
|
sub get_first_access { |
sub get_first_access { |
my ($type,$argsymb,$argmap,$ignorecache)=@_; |
my ($type,$argsymb,$argmap)=@_; |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
if ($argsymb) { $symb=$argsymb; } |
if ($argsymb) { $symb=$argsymb; } |
my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
Line 4852 sub get_first_access {
|
Line 4788 sub get_first_access {
|
} else { |
} else { |
$res=$symb; |
$res=$symb; |
} |
} |
&load_all_first_access($uname,$udom,$ignorecache); |
&load_all_first_access($uname,$udom); |
return $cachedtimes{"$courseid\0$res"}; |
return $cachedtimes{"$courseid\0$res"}; |
} |
} |
|
|
Line 6258 sub currentdump {
|
Line 6194 sub currentdump {
|
# |
# |
my %returnhash=(); |
my %returnhash=(); |
# |
# |
if ($rep eq 'unknown_cmd') { |
if ($rep eq "unknown_cmd") { |
# an old lond will not know currentdump |
# an old lond will not know currentdump |
# Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
Line 7191 sub allowed {
|
Line 7127 sub allowed {
|
|
|
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
# Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
&& ($priv eq 'bre')) { |
&& ($priv eq 'bre')) { |
return 'F'; |
return 'F'; |
Line 7852 sub get_commblock_resources {
|
Line 7788 sub get_commblock_resources {
|
} |
} |
} |
} |
} |
} |
if ($interval[0] =~ /^(\d+)/) { |
if ($interval[0] =~ /^\d+$/) { |
my $timelimit = $1; |
|
my $first_access; |
my $first_access; |
if ($type eq 'resource') { |
if ($type eq 'resource') { |
$first_access=&get_first_access($interval[1],$item); |
$first_access=&get_first_access($interval[1],$item); |
Line 7863 sub get_commblock_resources {
|
Line 7798 sub get_commblock_resources {
|
$first_access=&get_first_access($interval[1]); |
$first_access=&get_first_access($interval[1]); |
} |
} |
if ($first_access) { |
if ($first_access) { |
my $timesup = $first_access+$timelimit; |
my $timesup = $first_access+$interval[0]; |
if ($timesup > $now) { |
if ($timesup > $now) { |
my $activeblock; |
my $activeblock; |
foreach my $res (@to_test) { |
foreach my $res (@to_test) { |
Line 8612 sub auto_validate_class_sec {
|
Line 8547 sub auto_validate_class_sec {
|
return $response; |
return $response; |
} |
} |
|
|
|
sub auto_validate_instclasses { |
|
my ($cdom,$cnum,$owners,$classesref) = @_; |
|
my ($homeserver,%validations); |
|
$homeserver = &homeserver($cnum,$cdom); |
|
unless ($homeserver eq 'no_host') { |
|
my $ownerlist; |
|
if (ref($owners) eq 'ARRAY') { |
|
$ownerlist = join(',',@{$owners}); |
|
} else { |
|
$ownerlist = $owners; |
|
} |
|
if (ref($classesref) eq 'HASH') { |
|
my $classes = &freeze_escape($classesref); |
|
my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist). |
|
':'.$cdom.':'.$classes,$homeserver); |
|
unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
|
my @items = split(/&/,$response); |
|
foreach my $item (@items) { |
|
my ($key,$value) = split('=',$item); |
|
$validations{&unescape($key)} = &thaw_unescape($value); |
|
} |
|
} |
|
} |
|
} |
|
return %validations; |
|
} |
|
|
sub auto_crsreq_update { |
sub auto_crsreq_update { |
my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, |
my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, |
$code,$accessstart,$accessend,$inbound) = @_; |
$code,$accessstart,$accessend,$inbound) = @_; |
Line 9703 sub generate_coursenum {
|
Line 9665 sub generate_coursenum {
|
sub is_course { |
sub is_course { |
my ($cdom, $cnum) = scalar(@_) == 1 ? |
my ($cdom, $cnum) = scalar(@_) == 1 ? |
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; |
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; |
|
return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)); |
return unless $cdom and $cnum; |
my $uhome=&homeserver($cnum,$cdom); |
|
my $iscourse; |
my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef, |
if (grep { $_ eq $uhome } current_machine_ids()) { |
'.'); |
$iscourse = &LONCAPA::Lond::is_course($cdom,$cnum); |
|
} else { |
return unless(exists($courses{$cdom.'_'.$cnum})); |
my $hashid = $cdom.':'.$cnum; |
|
($iscourse,my $cached) = &is_cached_new('iscourse',$hashid); |
|
unless (defined($cached)) { |
|
my %courses = &courseiddump($cdom, '.', 1, '.', '.', |
|
$cnum,undef,undef,'.'); |
|
$iscourse = 0; |
|
if (exists($courses{$cdom.'_'.$cnum})) { |
|
$iscourse = 1; |
|
} |
|
&do_cache_new('iscourse',$hashid,$iscourse,3600); |
|
} |
|
} |
|
return unless($iscourse); |
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; |
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; |
} |
} |
|
|
Line 9891 sub files_not_in_path {
|
Line 9865 sub files_not_in_path {
|
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my @return_files; |
my @return_files; |
my $path_part; |
my $path_part; |
open(IN,'<',LONCAPA::tempdir().$filename); |
open(IN, '<',LONCAPA::tempdir().$filename); |
while (my $line = <IN>) { |
while (my $line = <IN>) { |
#ok, I know it's clunky, but I want it to work |
#ok, I know it's clunky, but I want it to work |
my @paths_and_file = split(m|/|, $line); |
my @paths_and_file = split(m|/|, $line); |
Line 10551 sub get_userresdata {
|
Line 10525 sub get_userresdata {
|
# Parameters: |
# Parameters: |
# $name - Course/user name. |
# $name - Course/user name. |
# $domain - Name of the domain the user/course is registered on. |
# $domain - Name of the domain the user/course is registered on. |
# $type - Type of thing $name is (must be 'course' or 'user') |
# $type - Type of thing $name is (must be 'course' or 'user' |
# @which - Array of names of resources desired. |
# @which - Array of names of resources desired. |
# Returns: |
# Returns: |
# The value of the first reasource in @which that is found in the |
# The value of the first reasource in @which that is found in the |
Line 10570 sub resdata {
|
Line 10544 sub resdata {
|
} |
} |
if (!ref($result)) { return $result; } |
if (!ref($result)) { return $result; } |
foreach my $item (@which) { |
foreach my $item (@which) { |
if (ref($item) eq 'ARRAY') { |
if (defined($result->{$item->[0]})) { |
if (defined($result->{$item->[0]})) { |
return [$result->{$item->[0]},$item->[1]]; |
return [$result->{$item->[0]},$item->[1]]; |
} |
} |
|
} |
|
} |
} |
return undef; |
return undef; |
} |
} |
|
|
sub get_domain_ltitools { |
|
my ($cdom) = @_; |
|
my %ltitools; |
|
my ($result,$cached)=&is_cached_new('ltitools',$cdom); |
|
if (defined($cached)) { |
|
if (ref($result) eq 'HASH') { |
|
%ltitools = %{$result}; |
|
} |
|
} else { |
|
my %domconfig = &get_dom('configuration',['ltitools'],$cdom); |
|
if (ref($domconfig{'ltitools'}) eq 'HASH') { |
|
%ltitools = %{$domconfig{'ltitools'}}; |
|
my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom); |
|
if (ref($encdomconfig{'ltitools'}) eq 'HASH') { |
|
foreach my $id (keys(%ltitools)) { |
|
if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') { |
|
foreach my $item ('key','secret') { |
|
$ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item}; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
my $cachetime = 24*60*60; |
|
&do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); |
|
} |
|
return %ltitools; |
|
} |
|
|
|
sub get_numsuppfiles { |
sub get_numsuppfiles { |
my ($cnum,$cdom,$ignorecache)=@_; |
my ($cnum,$cdom,$ignorecache)=@_; |
my $hashid=$cnum.':'.$cdom; |
my $hashid=$cnum.':'.$cdom; |
Line 11056 sub add_prefix_and_part {
|
Line 10999 sub add_prefix_and_part {
|
|
|
my %metaentry; |
my %metaentry; |
my %importedpartids; |
my %importedpartids; |
my %importedrespids; |
|
sub metadata { |
sub metadata { |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
# if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
if (($uri eq '') || |
if (($uri eq '') || |
(($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
return undef; |
return undef; |
} |
} |
Line 11084 sub metadata {
|
Line 11026 sub metadata {
|
} |
} |
{ |
{ |
# Imported parts would go here |
# Imported parts would go here |
my @origfiletagids=(); |
my %importedids=(); |
|
my @origfileimportpartids=(); |
my $importedparts=0; |
my $importedparts=0; |
|
|
# Imported responseids would go here |
|
my $importedresponses=0; |
|
# |
# |
# Is this a recursive call for a library? |
# Is this a recursive call for a library? |
# |
# |
Line 11183 sub metadata {
|
Line 11123 sub metadata {
|
my $dir=$filename; |
my $dir=$filename; |
$dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
$location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
|
|
my $importid=$token->[2]->{'id'}; |
|
my $importmode=$token->[2]->{'importmode'}; |
my $importmode=$token->[2]->{'importmode'}; |
# |
|
# Check metadata for imported file to |
|
# see if it contained response items |
|
# |
|
my %currmetaentry = %metaentry; |
|
my $libresponseorder = &metadata($location,'responseorder'); |
|
my $origfile; |
|
if ($libresponseorder ne '') { |
|
if ($#origfiletagids<0) { |
|
undef(%importedrespids); |
|
undef(%importedpartids); |
|
} |
|
@{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder); |
|
if (@{$importedrespids{$importid}} > 0) { |
|
$importedresponses = 1; |
|
# We need to get the original file and the imported file to get the response order correct |
|
# Load and inspect original file |
|
if ($#origfiletagids<0) { |
|
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
|
$origfile=&getfile($origfilelocation); |
|
@origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
} |
|
} |
|
} |
|
# Do not overwrite contents of %metaentry hash for resource itself with |
|
# hash populated for imported library file |
|
%metaentry = %currmetaentry; |
|
undef(%currmetaentry); |
|
if ($importmode eq 'problem') { |
if ($importmode eq 'problem') { |
# Import as problem/response |
# Import as problem/response |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
Line 11222 sub metadata {
|
Line 11133 sub metadata {
|
$importedparts=1; |
$importedparts=1; |
# We need to get the original file and the imported file to get the part order correct |
# We need to get the original file and the imported file to get the part order correct |
# Good news: we do not need to worry about nested libraries, since parts cannot be nested |
# Good news: we do not need to worry about nested libraries, since parts cannot be nested |
# Load and inspect original file if we didn't do that already |
# Load and inspect original file |
if ($#origfiletagids<0) { |
if ($#origfileimportpartids<0) { |
undef(%importedrespids); |
undef(%importedpartids); |
undef(%importedpartids); |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
if ($origfile eq '') { |
my $origfile=&getfile($origfilelocation); |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
@origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
$origfile=&getfile($origfilelocation); |
|
@origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
} |
|
} |
} |
|
|
# Load and inspect imported file |
# Load and inspect imported file |
Line 11344 sub metadata {
|
Line 11252 sub metadata {
|
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
$metaentry{':packages'} = join(',',@uniq_packages); |
$metaentry{':packages'} = join(',',@uniq_packages); |
|
|
if (($importedresponses) || ($importedparts)) { |
if ($importedparts) { |
if ($importedparts) { |
|
# We had imported parts and need to rebuild partorder |
# We had imported parts and need to rebuild partorder |
$metaentry{':partorder'}=''; |
$metaentry{':partorder'}=''; |
$metathesekeys{'partorder'}=1; |
$metathesekeys{'partorder'}=1; |
} |
for (my $index=0;$index<$#origfileimportpartids;$index+=2) { |
if ($importedresponses) { |
if ($origfileimportpartids[$index] eq 'part') { |
# We had imported responses and need to rebuild responseorder |
# original part, part of the problem |
$metaentry{':responseorder'}=''; |
$metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; |
$metathesekeys{'responseorder'}=1; |
} else { |
} |
# we have imported parts at this position |
for (my $index=0;$index<$#origfiletagids;$index+=2) { |
$metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; |
my $origid = $origfiletagids[$index+1]; |
} |
if ($origfiletagids[$index] eq 'part') { |
} |
# Original part, part of the problem |
$metaentry{':partorder'}=~s/^\,//; |
if ($importedparts) { |
|
$metaentry{':partorder'}.=','.$origid; |
|
} |
|
} elsif ($origfiletagids[$index] eq 'import') { |
|
if ($importedparts) { |
|
# We have imported parts at this position |
|
$metaentry{':partorder'}.=','.$importedpartids{$origid}; |
|
} |
|
if ($importedresponses) { |
|
# We have imported responses at this position |
|
if (ref($importedrespids{$origid}) eq 'ARRAY') { |
|
$metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}}); |
|
} |
|
} |
|
} else { |
|
# Original response item, part of the problem |
|
if ($importedresponses) { |
|
$metaentry{':responseorder'}.=','.$origid; |
|
} |
|
} |
|
} |
|
if ($importedparts) { |
|
$metaentry{':partorder'}=~s/^\,//; |
|
} |
|
if ($importedresponses) { |
|
$metaentry{':responseorder'}=~s/^\,//; |
|
} |
|
} |
} |
|
|
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
Line 12657 sub clutter {
|
Line 12537 sub clutter {
|
# &logthis("Got a blank emb style"); |
# &logthis("Got a blank emb style"); |
} |
} |
} |
} |
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { |
|
$thisfn='/adm/wrapper'.$thisfn; |
|
} |
} |
return $thisfn; |
return $thisfn; |
} |
} |
Line 12732 sub get_dns {
|
Line 12610 sub get_dns {
|
} |
} |
|
|
my %alldns; |
my %alldns; |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { |
foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
my $line = $1; |
my $line = $1; |
my ($host,$protocol) = split(/:/,$line); |
my ($host,$protocol) = split(/:/,$line); |
if ($protocol ne 'https') { |
if ($protocol ne 'https') { |
$protocol = 'http'; |
$protocol = 'http'; |
|
} |
|
$alldns{$host} = $protocol; |
} |
} |
$alldns{$host} = $protocol; |
close($config); |
} |
} |
while (%alldns) { |
while (%alldns) { |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
my ($dns) = sort { $b cmp $a } keys(%alldns); |