version 1.1056.4.11, 2010/10/01 14:26:07
|
version 1.1083, 2010/08/25 16:34:36
|
Line 263 sub get_server_homeID {
|
Line 263 sub get_server_homeID {
|
} |
} |
my $cachetime = 12*3600; |
my $cachetime = 12*3600; |
my $serverhomeID; |
my $serverhomeID; |
if ($caller eq 'loncron') { |
if ($caller eq 'loncron') { |
my @machine_ids = &machine_ids($hostname); |
my @machine_ids = &machine_ids($hostname); |
foreach my $id (@machine_ids) { |
foreach my $id (@machine_ids) { |
my $response = &reply('serverhomeID',$id); |
my $response = &reply('serverhomeID',$id); |
Line 724 sub userload {
|
Line 724 sub userload {
|
return $userloadpercent; |
return $userloadpercent; |
} |
} |
|
|
# ------------------------------------------ Fight off request when overloaded |
|
|
|
sub overloaderror { |
|
my ($r,$checkserver)=@_; |
|
unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } |
|
my $loadavg; |
|
if ($checkserver eq $perlvar{'lonHostID'}) { |
|
open(my $loadfile,'/proc/loadavg'); |
|
$loadavg=<$loadfile>; |
|
$loadavg =~ s/\s.*//g; |
|
$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; |
|
close($loadfile); |
|
} else { |
|
$loadavg=&reply('load',$checkserver); |
|
} |
|
my $overload=$loadavg-100; |
|
if ($overload>0) { |
|
$r->err_headers_out->{'Retry-After'}=$overload; |
|
$r->log_error('Overload of '.$overload.' on '.$checkserver); |
|
return 413; |
|
} |
|
return ''; |
|
} |
|
|
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
sub spareserver { |
sub spareserver { |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_; |
my $spare_server; |
my $spare_server; |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
: $userloadpercent; |
: $userloadpercent; |
my ($uint_dom,$remotesessions); |
my ($uint_dom,$remotesessions); |
if ($env{'user.domain'}) { |
if (($udom ne '') && (&domain($udom) ne '')) { |
my $uprimary_id = &Apache::lonnet::domain($env{'user.domain'},'primary'); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'}); |
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); |
$remotesessions = $udomdefaults{'remotesessions'}; |
$remotesessions = $udomdefaults{'remotesessions'}; |
} |
} |
foreach my $try_server (@{ $spareid{'primary'} }) { |
foreach my $try_server (@{ $spareid{'primary'} }) { |
if ($uint_dom) { |
if ($uint_dom) { |
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
$remotesessions,$try_server)); |
$try_server)); |
} |
} |
($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
&compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
Line 777 sub spareserver {
|
Line 753 sub spareserver {
|
if (!$found_server) { |
if (!$found_server) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
if ($uint_dom) { |
if ($uint_dom) { |
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
$remotesessions,$try_server)); |
$try_server)); |
} |
} |
($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
&compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
Line 807 sub compare_server_load {
|
Line 783 sub compare_server_load {
|
my $userloadans = &reply('userload',$try_server); |
my $userloadans = &reply('userload',$try_server); |
|
|
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
return; #didn't get a number from the server |
return; #didn't get a number from the server |
} |
} |
|
|
my $load; |
my $load; |
Line 1757 sub getsection {
|
Line 1733 sub getsection {
|
# If there is a role which has expired, return it. |
# If there is a role which has expired, return it. |
# |
# |
$courseid = &courseid_to_courseurl($courseid); |
$courseid = &courseid_to_courseurl($courseid); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
my %roleshash = &dump('roles',$udom,$unam,$courseid); |
my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra); |
|
foreach my $key (keys(%roleshash)) { |
foreach my $key (keys(%roleshash)) { |
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
my $section=$1; |
my $section=$1; |
Line 3061 sub get_my_roles {
|
Line 3036 sub get_my_roles {
|
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
my (%dumphash,%nothide); |
my (%dumphash,%nothide); |
if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
my $extra = &freeze_escape({'skipcheck' => 1}); |
%dumphash = &dump('roles',$udom,$uname); |
%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra); |
|
} else { |
} else { |
%dumphash= |
%dumphash= |
&dump('nohist_userroles',$udom,$uname); |
&dump('nohist_userroles',$udom,$uname); |
Line 3390 sub get_domain_roles {
|
Line 3364 sub get_domain_roles {
|
return %personnel; |
return %personnel; |
} |
} |
|
|
# ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Interval timing |
|
|
sub get_first_access { |
sub get_first_access { |
my ($type,$argsymb)=@_; |
my ($type,$argsymb)=@_; |
Line 3426 sub set_first_access {
|
Line 3400 sub set_first_access {
|
return 'already_set'; |
return 'already_set'; |
} |
} |
|
|
sub checkout { |
|
my ($symb,$tuname,$tudom,$tcrsid)=@_; |
|
my $now=time; |
|
my $lonhost=$perlvar{'lonHostID'}; |
|
my $infostr=&escape( |
|
'CHECKOUTTOKEN&'. |
|
$tuname.'&'. |
|
$tudom.'&'. |
|
$tcrsid.'&'. |
|
$symb.'&'. |
|
$now.'&'.$ENV{'REMOTE_ADDR'}); |
|
my $token=&reply('tmpput:'.$infostr,$lonhost); |
|
if ($token=~/^error\:/) { |
|
&logthis("<font color=\"blue\">WARNING: ". |
|
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. |
|
"</font>"); |
|
return ''; |
|
} |
|
|
|
$token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; |
|
$token=~tr/a-z/A-Z/; |
|
|
|
my %infohash=('resource.0.outtoken' => $token, |
|
'resource.0.checkouttime' => $now, |
|
'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); |
|
|
|
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
|
return ''; |
|
} else { |
|
&logthis("<font color=\"blue\">WARNING: ". |
|
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. |
|
"</font>"); |
|
} |
|
|
|
if (&log($tudom,$tuname,&homeserver($tuname,$tudom), |
|
&escape('Checkout '.$infostr.' - '. |
|
$token)) ne 'ok') { |
|
return ''; |
|
} else { |
|
&logthis("<font color=\"blue\">WARNING: ". |
|
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. |
|
"</font>"); |
|
} |
|
return $token; |
|
} |
|
|
|
# ------------------------------------------------------------ Check in an item |
|
|
|
sub checkin { |
|
my $token=shift; |
|
my $now=time; |
|
my ($ta,$tb,$lonhost)=split(/\*/,$token); |
|
$lonhost=~tr/A-Z/a-z/; |
|
my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb; |
|
$dtoken=~s/\W/\_/g; |
|
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
|
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
|
|
|
unless (($tuname) && ($tudom)) { |
|
&logthis('Check in '.$token.' ('.$dtoken.') failed'); |
|
return ''; |
|
} |
|
|
|
unless (&allowed('mgr',$tcrsid)) { |
|
&logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. |
|
$env{'user.name'}.' - '.$env{'user.domain'}); |
|
return ''; |
|
} |
|
|
|
my %infohash=('resource.0.intoken' => $token, |
|
'resource.0.checkintime' => $now, |
|
'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); |
|
|
|
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
|
return ''; |
|
} |
|
|
|
if (&log($tudom,$tuname,&homeserver($tuname,$tudom), |
|
&escape('Checkin - '.$token)) ne 'ok') { |
|
return ''; |
|
} |
|
|
|
return ($symb,$tuname,$tudom,$tcrsid); |
|
} |
|
|
|
# --------------------------------------------- Set Expire Date for Spreadsheet |
# --------------------------------------------- Set Expire Date for Spreadsheet |
|
|
sub expirespread { |
sub expirespread { |
Line 4126 sub rolesinit {
|
Line 4015 sub rolesinit {
|
my ($domain,$username,$authhost)=@_; |
my ($domain,$username,$authhost)=@_; |
my $now=time; |
my $now=time; |
my %userroles = ('user.login.time' => $now); |
my %userroles = ('user.login.time' => $now); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
my $extra = &freeze_escape({'clientcheckrole' => 1}); |
my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost); |
my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost); |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
($rolesdump =~ /^error:/)) { |
($rolesdump =~ /^error:/)) { |
Line 4255 sub set_userprivs {
|
Line 4144 sub set_userprivs {
|
my $adv=0; |
my $adv=0; |
my %grouproles = (); |
my %grouproles = (); |
if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
my @groupkeys; |
my @groupkeys; |
foreach my $role (keys(%{$allroles})) { |
foreach my $role (keys(%{$allroles})) { |
push(@groupkeys,$role); |
push(@groupkeys,$role); |
} |
} |
Line 4331 sub role_status {
|
Line 4220 sub role_status {
|
my %userroles = ( |
my %userroles = ( |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
); |
); |
@rolecodes = ('cm'); |
@rolecodes = ('cm'); |
my $spec=$$role.'.'.$$where; |
my $spec=$$role.'.'.$$where; |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
if ($$role =~ /^cr\//) { |
if ($$role =~ /^cr\//) { |
Line 4348 sub role_status {
|
Line 4237 sub role_status {
|
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); |
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); |
if (keys(%course_roles) > 0) { |
if (keys(%course_roles) > 0) { |
my ($tnum) = ($trest =~ /^($match_courseid)/); |
my ($tnum) = ($trest =~ /^($match_courseid)/); |
if ($tdomain ne '' && $tnum ne '') { |
if ($tdomain ne '' && $tnum ne '') { |
foreach my $key (keys(%course_roles)) { |
foreach my $key (keys(%course_roles)) { |
if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) { |
if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) { |
my $crsrole = $1; |
my $crsrole = $1; |
Line 4477 sub del {
|
Line 4366 sub del {
|
# -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
|
|
sub dump { |
sub dump { |
my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
Line 4486 sub dump {
|
Line 4375 sub dump {
|
} else { |
} else { |
$regexp='.'; |
$regexp='.'; |
} |
} |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome); |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
my %returnhash=(); |
my %returnhash=(); |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
Line 5031 sub is_portfolio_file {
|
Line 4920 sub is_portfolio_file {
|
} |
} |
|
|
sub usertools_access { |
sub usertools_access { |
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_; |
my ($uname,$udom,$tool,$action,$context) = @_; |
my ($access,%tools); |
my ($access,%tools); |
if ($context eq '') { |
if ($context eq '') { |
$context = 'tools'; |
$context = 'tools'; |
Line 5073 sub usertools_access {
|
Line 4962 sub usertools_access {
|
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
$inststatus = $env{'environment.inststatus'}; |
$inststatus = $env{'environment.inststatus'}; |
} else { |
} else { |
if (ref($userenvref) eq 'HASH') { |
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); |
$toolstatus = $userenvref->{$context.'.'.$tool}; |
$toolstatus = $userenv{$context.'.'.$tool}; |
$inststatus = $userenvref->{'inststatus'}; |
$inststatus = $userenv{'inststatus'}; |
} else { |
|
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); |
|
$toolstatus = $userenv{$context.'.'.$tool}; |
|
$inststatus = $userenv{'inststatus'}; |
|
} |
|
} |
} |
|
|
if ($toolstatus ne '') { |
if ($toolstatus ne '') { |
Line 5092 sub usertools_access {
|
Line 4976 sub usertools_access {
|
return $access; |
return $access; |
} |
} |
|
|
my ($is_adv,%domdef); |
my $is_adv = &is_advanced_user($udom,$uname); |
if (ref($is_advref) eq 'HASH') { |
my %domdef = &get_domain_defaults($udom); |
$is_adv = $is_advref->{'is_adv'}; |
|
} else { |
|
$is_adv = &is_advanced_user($udom,$uname); |
|
} |
|
if (ref($domdefref) eq 'HASH') { |
|
%domdef = %{$domdefref}; |
|
} else { |
|
%domdef = &get_domain_defaults($udom); |
|
} |
|
if (ref($domdef{$tool}) eq 'HASH') { |
if (ref($domdef{$tool}) eq 'HASH') { |
if ($is_adv) { |
if ($is_adv) { |
if ($domdef{$tool}{'_LC_adv'} ne '') { |
if ($domdef{$tool}{'_LC_adv'} ne '') { |
Line 5176 sub is_course_owner {
|
Line 5051 sub is_course_owner {
|
|
|
sub is_advanced_user { |
sub is_advanced_user { |
my ($udom,$uname) = @_; |
my ($udom,$uname) = @_; |
if ($udom ne '' && $uname ne '') { |
|
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
|
return $env{'user.adv'}; |
|
} |
|
} |
|
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
my %allroles; |
my %allroles; |
my $is_adv; |
my $is_adv; |
Line 6466 sub get_users_groups {
|
Line 6336 sub get_users_groups {
|
} else { |
} else { |
$grouplist = ''; |
$grouplist = ''; |
my $courseurl = &courseid_to_courseurl($courseid); |
my $courseurl = &courseid_to_courseurl($courseid); |
my $extra = &freeze_escape({'skipcheck' => 1}); |
my %roleshash = &dump('roles',$udom,$uname,$courseurl); |
my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra); |
|
my $access_end = $env{'course.'.$courseid. |
my $access_end = $env{'course.'.$courseid. |
'.default_enrollment_end_date'}; |
'.default_enrollment_end_date'}; |
my $now = time; |
my $now = time; |
Line 6821 sub modifyuser {
|
Line 6690 sub modifyuser {
|
} |
} |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
$umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
' desiredhome not specified'). |
' desiredhome not specified'). |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
Line 6967 sub modifyuser {
|
Line 6836 sub modifyuser {
|
return 'ok'; |
return 'ok'; |
} |
} |
my $reply = &put('environment', \%names, $udom,$uname); |
my $reply = &put('environment', \%names, $udom,$uname); |
if ($reply ne 'ok') { |
if ($reply ne 'ok') { |
return 'error: '.$reply; |
return 'error: '.$reply; |
} |
} |
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { |
|
&Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom); |
|
} |
|
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
$logmsg = 'Success modifying user '.$logmsg; |
$logmsg = 'Success modifying user '.$logmsg; |
Line 8508 sub add_prefix_and_part {
|
Line 8374 sub add_prefix_and_part {
|
# ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
|
|
my %metaentry; |
my %metaentry; |
|
my %importedpartids; |
sub metadata { |
sub metadata { |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
Line 8534 sub metadata {
|
Line 8401 sub metadata {
|
if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
} |
} |
{ |
{ |
|
# Imported parts would go here |
|
my %importedids=(); |
|
my @origfileimportpartids=(); |
|
my $importedparts=0; |
# |
# |
# Is this a recursive call for a library? |
# Is this a recursive call for a library? |
# |
# |
Line 8617 sub metadata {
|
Line 8488 sub metadata {
|
# This is not a package - some other kind of start tag |
# This is not a package - some other kind of start tag |
# |
# |
my $entry=$token->[1]; |
my $entry=$token->[1]; |
my $unikey; |
my $unikey=''; |
if ($entry eq 'import') { |
|
$unikey=''; |
|
} else { |
|
$unikey=$entry; |
|
} |
|
$unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
|
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
|
|
|
if ($entry eq 'import') { |
if ($entry eq 'import') { |
# |
# |
# Importing a library here |
# Importing a library here |
# |
# |
|
my $location=$parser->get_text('/import'); |
|
my $dir=$filename; |
|
$dir=~s|[^/]*$||; |
|
$location=&filelocation($dir,$location); |
|
|
|
my $importmode=$token->[2]->{'importmode'}; |
|
if ($importmode eq 'problem') { |
|
# Import as problem/response |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
} elsif ($importmode eq 'part') { |
|
# Import as part(s) |
|
$importedparts=1; |
|
# 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 |
|
# Load and inspect original file |
|
if ($#origfileimportpartids<0) { |
|
undef(%importedpartids); |
|
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
|
my $origfile=&getfile($origfilelocation); |
|
@origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
} |
|
|
|
# Load and inspect imported file |
|
my $impfile=&getfile($location); |
|
my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
|
if ($#impfilepartids>=0) { |
|
# This problem had parts |
|
$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); |
|
} else { |
|
# Importing by turning a single problem into a problem part |
|
# It gets the import-tags ID as part-ID |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'}); |
|
$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'}; |
|
} |
|
} else { |
|
# Normal import |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
|
} |
|
|
if ($depthcount<20) { |
if ($depthcount<20) { |
my $location=$parser->get_text('/import'); |
|
my $dir=$filename; |
|
$dir=~s|[^/]*$||; |
|
$location=&filelocation($dir,$location); |
|
my $metadata = |
my $metadata = |
&metadata($uri,'keys', $location,$unikey, |
&metadata($uri,'keys', $location,$unikey, |
$depthcount+1); |
$depthcount+1); |
Line 8645 sub metadata {
|
Line 8544 sub metadata {
|
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metathesekeys{$meta}=1; |
$metathesekeys{$meta}=1; |
} |
} |
} |
|
} else { |
} |
|
} else { |
|
# |
|
# Not importing, some other kind of non-package, non-library start tag |
|
# |
|
$unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
$unikey.='_'.$token->[2]->{'name'}; |
$unikey.='_'.$token->[2]->{'name'}; |
} |
} |
Line 8720 sub metadata {
|
Line 8627 sub metadata {
|
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
$metaentry{':packages'} = join(',',@uniq_packages); |
$metaentry{':packages'} = join(',',@uniq_packages); |
|
|
|
if ($importedparts) { |
|
# We had imported parts and need to rebuild partorder |
|
$metaentry{':partorder'}=''; |
|
$metathesekeys{'partorder'}=1; |
|
for (my $index=0;$index<$#origfileimportpartids;$index+=2) { |
|
if ($origfileimportpartids[$index] eq 'part') { |
|
# original part, part of the problem |
|
$metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; |
|
} else { |
|
# we have imported parts at this position |
|
$metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; |
|
} |
|
} |
|
$metaentry{':partorder'}=~s/^\,//; |
|
} |
|
|
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
Line 10085 sub get_dns {
|
Line 10008 sub get_dns {
|
} |
} |
|
|
sub unique_library { |
sub unique_library { |
#2x reverse removes all hostnames that appear more than once |
#2x reverse removes all hostnames that appear more than once |
my %unique = reverse &all_library(); |
my %unique = reverse &all_library(); |
return reverse %unique; |
return reverse %unique; |
} |
} |
Line 10115 sub get_dns {
|
Line 10038 sub get_dns {
|
|
|
sub get_unique_servers { |
sub get_unique_servers { |
my %unique = reverse &get_servers(@_); |
my %unique = reverse &get_servers(@_); |
return reverse %unique; |
return reverse %unique; |
} |
} |
|
|
sub host_domain { |
sub host_domain { |
Line 10651 $checkdefauth is optional (value is 1 if
|
Line 10574 $checkdefauth is optional (value is 1 if
|
authenticate user using default authentication method, and allow |
authenticate user using default authentication method, and allow |
account creation if username does not have account in the domain). |
account creation if username does not have account in the domain). |
$clientcancheckhost is optional (value is 1 if checking whether the |
$clientcancheckhost is optional (value is 1 if checking whether the |
server can host will occur on the client side in lonauth.pm). |
server can host will occur on the client side in lonauth.pm). |
|
|
=item * |
=item * |
X<homeserver()> |
X<homeserver()> |