version 1.1172.2.89, 2017/01/22 17:41:07
|
version 1.1172.2.96, 2018/09/02 23:22:47
|
Line 142 our @EXPORT = qw(%env);
|
Line 142 our @EXPORT = qw(%env);
|
sub logtouch { |
sub logtouch { |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
unless (-e "$execdir/logs/lonnet.log") { |
unless (-e "$execdir/logs/lonnet.log") { |
open(my $fh,">>$execdir/logs/lonnet.log"); |
open(my $fh,">>","$execdir/logs/lonnet.log"); |
close $fh; |
close $fh; |
} |
} |
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; |
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; |
Line 154 sub logthis {
|
Line 154 sub logthis {
|
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
my $now=time; |
my $now=time; |
my $local=localtime($now); |
my $local=localtime($now); |
if (open(my $fh,">>$execdir/logs/lonnet.log")) { |
if (open(my $fh,">>","$execdir/logs/lonnet.log")) { |
my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. |
my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. |
print $fh $logstring; |
print $fh $logstring; |
close($fh); |
close($fh); |
Line 167 sub logperm {
|
Line 167 sub logperm {
|
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
my $now=time; |
my $now=time; |
my $local=localtime($now); |
my $local=localtime($now); |
if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { |
if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) { |
print $fh "$now:$message:$local\n"; |
print $fh "$now:$message:$local\n"; |
close($fh); |
close($fh); |
} |
} |
Line 436 sub reconlonc {
|
Line 436 sub reconlonc {
|
|
|
&logthis("Trying to reconnect lonc"); |
&logthis("Trying to reconnect lonc"); |
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
if (open(my $fh,"<$loncfile")) { |
if (open(my $fh,"<",$loncfile)) { |
my $loncpid=<$fh>; |
my $loncpid=<$fh>; |
chomp($loncpid); |
chomp($loncpid); |
if (kill 0 => $loncpid) { |
if (kill 0 => $loncpid) { |
Line 476 sub critical {
|
Line 476 sub critical {
|
$dumpcount++; |
$dumpcount++; |
{ |
{ |
my $dfh; |
my $dfh; |
if (open($dfh,">$dfilename")) { |
if (open($dfh,">",$dfilename)) { |
print $dfh "$cmd\n"; |
print $dfh "$cmd\n"; |
close($dfh); |
close($dfh); |
} |
} |
Line 485 sub critical {
|
Line 485 sub critical {
|
my $wcmd=''; |
my $wcmd=''; |
{ |
{ |
my $dfh; |
my $dfh; |
if (open($dfh,"<$dfilename")) { |
if (open($dfh,"<",$dfilename)) { |
$wcmd=<$dfh>; |
$wcmd=<$dfh>; |
close($dfh); |
close($dfh); |
} |
} |
Line 601 sub transfer_profile_to_env {
|
Line 601 sub transfer_profile_to_env {
|
|
|
# ---------------------------------------------------- Check for valid session |
# ---------------------------------------------------- Check for valid session |
sub check_for_valid_session { |
sub check_for_valid_session { |
my ($r,$name,$userhashref) = @_; |
my ($r,$name,$userhashref,$domref) = @_; |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
if ($name eq '') { |
if ($name eq '') { |
$name = 'lonID'; |
$name = 'lonID'; |
Line 616 sub check_for_valid_session {
|
Line 616 sub check_for_valid_session {
|
} else { |
} else { |
$lonidsdir=$r->dir_config('lonIDsDir'); |
$lonidsdir=$r->dir_config('lonIDsDir'); |
} |
} |
return undef if (!-e "$lonidsdir/$handle.id"); |
if (!-e "$lonidsdir/$handle.id") { |
|
if ((ref($domref)) && ($name eq 'lonID') && |
|
($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { |
|
my ($possuname,$possudom,$possuhome) = ($1,$2,$3); |
|
if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { |
|
$$domref = $possudom; |
|
} |
|
} |
|
return undef; |
|
} |
|
|
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
return undef if (!$opened); |
return undef if (!$opened); |
Line 686 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 1829 sub inst_directory_query {
|
Line 1841 sub inst_directory_query {
|
&escape($srch->{'srchtype'}),$homeserver); |
&escape($srch->{'srchtype'}),$homeserver); |
my $host=&hostname($homeserver); |
my $host=&hostname($homeserver); |
if ($queryid !~/^\Q$host\E\_/) { |
if ($queryid !~/^\Q$host\E\_/) { |
&logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); |
&logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); |
return; |
return; |
} |
} |
my $response = &get_query_reply($queryid); |
my $response = &get_query_reply($queryid); |
Line 2112 sub get_domain_defaults {
|
Line 2124 sub get_domain_defaults {
|
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
|
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; |
|
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; |
|
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; |
} else { |
} else { |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
Line 3191 sub process_coursefile {
|
Line 3206 sub process_coursefile {
|
$home); |
$home); |
} |
} |
} elsif ($action eq 'uploaddoc') { |
} elsif ($action eq 'uploaddoc') { |
open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>',$filepath.'/'.$fname); |
print $fh $env{'form.'.$source}; |
print $fh $env{'form.'.$source}; |
close($fh); |
close($fh); |
if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
Line 3249 sub store_edited_file {
|
Line 3264 sub store_edited_file {
|
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
my $filepath = &build_filepath($fpath); |
my $filepath = &build_filepath($fpath); |
open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>',$filepath.'/'.$fname); |
print $fh $content; |
print $fh $content; |
close($fh); |
close($fh); |
my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
Line 3365 sub userfileupload {
|
Line 3380 sub userfileupload {
|
'_'.$env{'user.domain'}.'/pending'; |
'_'.$env{'user.domain'}.'/pending'; |
} elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { |
} elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { |
my ($docuname,$docudom); |
my ($docuname,$docudom); |
if ($destudom) { |
if ($destudom =~ /^$match_domain$/) { |
$docudom = $destudom; |
$docudom = $destudom; |
} else { |
} else { |
$docudom = $env{'user.domain'}; |
$docudom = $env{'user.domain'}; |
} |
} |
if ($destuname) { |
if ($destuname =~ /^$match_username$/) { |
$docuname = $destuname; |
$docuname = $destuname; |
} else { |
} else { |
$docuname = $env{'user.name'}; |
$docuname = $env{'user.name'}; |
Line 3400 sub userfileupload {
|
Line 3415 sub userfileupload {
|
mkdir($fullpath,0777); |
mkdir($fullpath,0777); |
} |
} |
} |
} |
open(my $fh,'>'.$fullpath.'/'.$fname); |
open(my $fh,'>',$fullpath.'/'.$fname); |
print $fh $env{'form.'.$formname}; |
print $fh $env{'form.'.$formname}; |
close($fh); |
close($fh); |
if ($context eq 'existingfile') { |
if ($context eq 'existingfile') { |
Line 3475 sub finishuserfileupload {
|
Line 3490 sub finishuserfileupload {
|
|
|
# Save the file |
# Save the file |
{ |
{ |
if (!open(FH,'>'.$filepath.'/'.$file)) { |
if (!open(FH,'>',$filepath.'/'.$file)) { |
&logthis('Failed to create '.$filepath.'/'.$file); |
&logthis('Failed to create '.$filepath.'/'.$file); |
print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); |
print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); |
return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
Line 3533 sub finishuserfileupload {
|
Line 3548 sub finishuserfileupload {
|
my $input = $filepath.'/'.$file; |
my $input = $filepath.'/'.$file; |
my $output = $filepath.'/'.'tn-'.$file; |
my $output = $filepath.'/'.'tn-'.$file; |
my $thumbsize = $thumbwidth.'x'.$thumbheight; |
my $thumbsize = $thumbwidth.'x'.$thumbheight; |
system("convert -sample $thumbsize $input $output"); |
my @args = ('convert','-sample',$thumbsize,$input,$output); |
|
system({$args[0]} @args); |
if (-e $filepath.'/'.'tn-'.$file) { |
if (-e $filepath.'/'.'tn-'.$file) { |
$fetchthumb = 1; |
$fetchthumb = 1; |
} |
} |
Line 3917 sub flushcourselogs {
|
Line 3933 sub flushcourselogs {
|
} |
} |
} |
} |
# |
# |
# Reverse lookup of domain roles (dc, ad, li, sc, dh, au) |
# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au) |
# |
# |
my %domrolebuffer = (); |
my %domrolebuffer = (); |
foreach my $entry (keys(%domainrolehash)) { |
foreach my $entry (keys(%domainrolehash)) { |
Line 4064 sub userrolelog {
|
Line 4080 sub userrolelog {
|
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
=$tend.':'.$tstart; |
=$tend.':'.$tstart; |
} |
} |
if ($trole =~ /^(dc|ad|li|au|dg|sc|dh)/ ) { |
if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
$domainrolehash |
$domainrolehash |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
Line 4348 sub get_my_adhocroles {
|
Line 4364 sub get_my_adhocroles {
|
} |
} |
} |
} |
if (($cdom ne '') && ($cnum ne '')) { |
if (($cdom ne '') && ($cnum ne '')) { |
if ($env{"user.role.dh./$cdom/"}) { |
if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { |
my $then=$env{'user.login.time'}; |
my $then=$env{'user.login.time'}; |
my $update=$env{'user.update.time'}; |
my $update=$env{'user.update.time'}; |
my $liverole = 1; |
if (!$update) { |
my ($tstart,$tend)=split(/\./,$env{'user.role.dh./'.$cdom}); |
$update = $then; |
my $limit = $update; |
} |
if ($env{'request.role'} eq 'dh./'.$cdom.'/') { |
my @liveroles; |
$limit = $then; |
foreach my $role ('dh','da') { |
} |
if ($env{"user.role.$role./$cdom/"}) { |
if ($tstart && $tstart>$limit) { $liverole = 0; } |
my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); |
if ($tend && $tend <$limit) { $liverole = 0; } |
my $limit = $update; |
if ($liverole) { |
if ($env{'request.role'} eq "$role./$cdom/") { |
|
$limit = $then; |
|
} |
|
my $activerole = 1; |
|
if ($tstart && $tstart>$limit) { $activerole = 0; } |
|
if ($tend && $tend <$limit) { $activerole = 0; } |
|
if ($activerole) { |
|
push(@liveroles,$role); |
|
} |
|
} |
|
} |
|
if (@liveroles) { |
if (&homeserver($cnum,$cdom) ne 'no_host') { |
if (&homeserver($cnum,$cdom) ne 'no_host') { |
my ($accessref,$accessinfo,%access_in_dom); |
my ($accessref,$accessinfo,%access_in_dom); |
($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); |
($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); |
Line 4414 sub get_my_adhocroles {
|
Line 4441 sub get_my_adhocroles {
|
next; |
next; |
} elsif ($curraccess eq 'all') { |
} elsif ($curraccess eq 'all') { |
push(@possroles,$role); |
push(@possroles,$role); |
|
} elsif ($curraccess eq 'dh') { |
|
if (grep(/^dh$/,@liveroles)) { |
|
push(@possroles,$role); |
|
} else { |
|
next; |
|
} |
|
} elsif ($curraccess eq 'da') { |
|
if (grep(/^da$/,@liveroles)) { |
|
push(@possroles,$role); |
|
} else { |
|
next; |
|
} |
} elsif ($curraccess eq 'status') { |
} elsif ($curraccess eq 'status') { |
if (@okstatus) { |
if (@okstatus) { |
if (!@statuses) { |
if (!@statuses) { |
Line 4470 sub postannounce {
|
Line 4509 sub postannounce {
|
|
|
sub getannounce { |
sub getannounce { |
|
|
if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
my $announcement=''; |
my $announcement=''; |
while (my $line = <$fh>) { $announcement .= $line; } |
while (my $line = <$fh>) { $announcement .= $line; } |
close($fh); |
close($fh); |
Line 5650 sub rolesinit {
|
Line 5689 sub rolesinit {
|
} |
} |
} |
} |
|
|
@userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles, |
@userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, |
\%allroles, \%allgroups); |
\%allroles, \%allgroups); |
$env{'user.adv'} = $userroles{'user.adv'}; |
$env{'user.adv'} = $userroles{'user.adv'}; |
|
$env{'user.rar'} = $userroles{'user.rar'}; |
|
|
return (\%userroles,\%firstaccenv,\%timerintenv); |
return (\%userroles,\%firstaccenv,\%timerintenv); |
} |
} |
Line 5776 sub set_userprivs {
|
Line 5816 sub set_userprivs {
|
my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
my $author=0; |
my $author=0; |
my $adv=0; |
my $adv=0; |
|
my $rar=0; |
my %grouproles = (); |
my %grouproles = (); |
if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
my @groupkeys; |
my @groupkeys; |
Line 5823 sub set_userprivs {
|
Line 5864 sub set_userprivs {
|
$thesepriv{$privilege}.=$restrictions; |
$thesepriv{$privilege}.=$restrictions; |
} |
} |
if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
|
if ($thesepriv{'rar'} eq 'F') { $rar=1; } |
} |
} |
} |
} |
my $thesestr=''; |
my $thesestr=''; |
Line 5831 sub set_userprivs {
|
Line 5873 sub set_userprivs {
|
} |
} |
$userroles->{'user.priv.'.$role} = $thesestr; |
$userroles->{'user.priv.'.$role} = $thesestr; |
} |
} |
return ($author,$adv); |
return ($author,$adv,$rar); |
} |
} |
|
|
sub role_status { |
sub role_status { |
Line 5876 sub role_status {
|
Line 5918 sub role_status {
|
push(@rolecodes,$$role); |
push(@rolecodes,$$role); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
} |
} |
my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, |
|
\%groups_roles); |
&appenv(\%userroles,\@rolecodes); |
&appenv(\%userroles,\@rolecodes); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); |
} |
} |
} |
} |
$$tstatus = 'is'; |
$$tstatus = 'is'; |
Line 5997 sub set_adhoc_privileges {
|
Line 6040 sub set_adhoc_privileges {
|
} else { |
} else { |
&standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); |
&standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); |
} |
} |
my ($author,$adv)= &set_userprivs(\%userroles,\%rolehash); |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); |
&appenv(\%userroles,[$role,'cm']); |
&appenv(\%userroles,[$role,'cm']); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); |
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { |
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { |
&appenv( {'request.role' => $spec, |
&appenv( {'request.role' => $spec, |
'request.role.domain' => $dcdom, |
'request.role.domain' => $dcdom, |
Line 8055 sub fetch_enrollment_query {
|
Line 8098 sub fetch_enrollment_query {
|
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
return 'error: '.$queryid; |
return 'error: '.$queryid; |
} |
} |
my $reply = &get_query_reply($queryid,$sleep.$loopmax); |
my $reply = &get_query_reply($queryid,$sleep,$loopmax); |
my $tries = 1; |
my $tries = 1; |
while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
$reply = &get_query_reply($queryid,$sleep,$loopmax); |
$reply = &get_query_reply($queryid,$sleep,$loopmax); |
Line 8083 sub fetch_enrollment_query {
|
Line 8126 sub fetch_enrollment_query {
|
if ($xml_classlist =~ /^error/) { |
if ($xml_classlist =~ /^error/) { |
&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); |
&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); |
} else { |
} else { |
if ( open(FILE,">$destname") ) { |
if ( open(FILE,">",$destname) ) { |
print FILE &unescape($xml_classlist); |
print FILE &unescape($xml_classlist); |
close(FILE); |
close(FILE); |
} else { |
} else { |
Line 8112 sub get_query_reply {
|
Line 8155 sub get_query_reply {
|
for (1..$loopmax) { |
for (1..$loopmax) { |
sleep($sleep); |
sleep($sleep); |
if (-e $replyfile.'.end') { |
if (-e $replyfile.'.end') { |
if (open(my $fh,$replyfile)) { |
if (open(my $fh,"<",$replyfile)) { |
$reply = join('',<$fh>); |
$reply = join('',<$fh>); |
close($fh); |
close($fh); |
} else { return 'error: reply_file_error'; } |
} else { return 'error: reply_file_error'; } |
Line 8504 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 8997 sub assignrole {
|
Line 9067 sub assignrole {
|
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
$selfenroll,$context); |
$selfenroll,$context); |
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
($role eq 'au') || ($role eq 'dc') || ($role eq 'dh')) { |
($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || |
|
($role eq 'da')) { |
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
$context); |
$context); |
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
Line 9594 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 9736 sub save_selected_files {
|
Line 9819 sub save_selected_files {
|
my ($user, $path, @files) = @_; |
my ($user, $path, @files) = @_; |
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my @other_files = &files_not_in_path($user, $path); |
my @other_files = &files_not_in_path($user, $path); |
open (OUT, '>'.$tmpdir.$filename); |
open (OUT,'>',LONCAPA::tempdir().$filename); |
foreach my $file (@files) { |
foreach my $file (@files) { |
print (OUT $env{'form.currentpath'}.$file."\n"); |
print (OUT $env{'form.currentpath'}.$file."\n"); |
} |
} |
Line 9750 sub save_selected_files {
|
Line 9833 sub save_selected_files {
|
sub clear_selected_files { |
sub clear_selected_files { |
my ($user) = @_; |
my ($user) = @_; |
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
open (OUT, '>'.LONCAPA::tempdir().$filename); |
open (OUT,'>',LONCAPA::tempdir().$filename); |
print (OUT undef); |
print (OUT undef); |
close (OUT); |
close (OUT); |
return ("ok"); |
return ("ok"); |
Line 9760 sub files_in_path {
|
Line 9843 sub files_in_path {
|
my ($user, $path) = @_; |
my ($user, $path) = @_; |
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my %return_files; |
my %return_files; |
open (IN, '<'.LONCAPA::tempdir().$filename); |
open (IN,'<',LONCAPA::tempdir().$filename); |
while (my $line_in = <IN>) { |
while (my $line_in = <IN>) { |
chomp ($line_in); |
chomp ($line_in); |
my @paths_and_file = split (m!/!, $line_in); |
my @paths_and_file = split (m!/!, $line_in); |
Line 9782 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::.$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 12270 sub readfile {
|
Line 12353 sub readfile {
|
my $file = shift; |
my $file = shift; |
if ( (! -e $file ) || ($file eq '') ) { return -1; }; |
if ( (! -e $file ) || ($file eq '') ) { return -1; }; |
my $fh; |
my $fh; |
open($fh,"<$file"); |
open($fh,"<",$file); |
my $a=''; |
my $a=''; |
while (my $line = <$fh>) { $a .= $line; } |
while (my $line = <$fh>) { $a .= $line; } |
return $a; |
return $a; |
Line 12383 sub machine_ids {
|
Line 12466 sub machine_ids {
|
|
|
sub additional_machine_domains { |
sub additional_machine_domains { |
my @domains; |
my @domains; |
open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); |
open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); |
while( my $line = <$fh>) { |
while( my $line = <$fh>) { |
$line =~ s/\s//g; |
$line =~ s/\s//g; |
push(@domains,$line); |
push(@domains,$line); |
Line 12527 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); |
Line 12555 sub get_dns {
|
Line 12640 sub get_dns {
|
close($config); |
close($config); |
my $which = (split('/',$url))[3]; |
my $which = (split('/',$url))[3]; |
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); |
open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab"); |
my @content = <$config>; |
my @content = <$config>; |
&$func(\@content,$hashref); |
&$func(\@content,$hashref); |
return; |
return; |
Line 12648 sub fetch_dns_checksums {
|
Line 12733 sub fetch_dns_checksums {
|
my ($ignore_cache,$nocache) = @_; |
my ($ignore_cache,$nocache) = @_; |
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); |
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); |
my $fh; |
my $fh; |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) { |
my @lines = <$fh>; |
my @lines = <$fh>; |
&parse_domain_tab(\@lines); |
&parse_domain_tab(\@lines); |
} |
} |
Line 12700 sub fetch_dns_checksums {
|
Line 12785 sub fetch_dns_checksums {
|
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
$name=~s/\s//g; |
$name=~s/\s//g; |
if ($id && $domain && $role && $name) { |
if ($id && $domain && $role && $name) { |
|
if ((exists($hostname{$id})) && ($hostname{$id} ne '')) { |
|
my $curr = $hostname{$id}; |
|
my $skip; |
|
if (ref($name_to_host{$curr}) eq 'ARRAY') { |
|
if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) { |
|
$skip = 1; |
|
} else { |
|
@{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}}; |
|
} |
|
} |
|
unless ($skip) { |
|
push(@{$name_to_host{$name}},$id); |
|
} |
|
} else { |
|
push(@{$name_to_host{$name}},$id); |
|
} |
$hostname{$id}=$name; |
$hostname{$id}=$name; |
push(@{$name_to_host{$name}}, $id); |
|
$hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
if (defined($protocol)) { |
if (defined($protocol)) { |
Line 12734 sub fetch_dns_checksums {
|
Line 12834 sub fetch_dns_checksums {
|
sub load_hosts_tab { |
sub load_hosts_tab { |
my ($ignore_cache,$nocache) = @_; |
my ($ignore_cache,$nocache) = @_; |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
my @config = <$config>; |
my @config = <$config>; |
&parse_hosts_tab(\@config); |
&parse_hosts_tab(\@config); |
close($config); |
close($config); |
Line 13000 sub all_loncaparevs {
|
Line 13100 sub all_loncaparevs {
|
{ |
{ |
sub load_loncaparevs { |
sub load_loncaparevs { |
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { |
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { |
if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { |
if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) { |
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
my ($hostid,$loncaparev)=split(/:/,$configline); |
my ($hostid,$loncaparev)=split(/:/,$configline); |
Line 13016 sub all_loncaparevs {
|
Line 13116 sub all_loncaparevs {
|
{ |
{ |
sub load_serverhomeIDs { |
sub load_serverhomeIDs { |
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { |
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { |
if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { |
if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { |
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
my ($name,$id)=split(/:/,$configline); |
my ($name,$id)=split(/:/,$configline); |
Line 13041 BEGIN {
|
Line 13141 BEGIN {
|
|
|
# ------------------------------------------------------ Read spare server file |
# ------------------------------------------------------ Read spare server file |
{ |
{ |
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab"); |
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
Line 13055 BEGIN {
|
Line 13155 BEGIN {
|
} |
} |
# ------------------------------------------------------------ Read permissions |
# ------------------------------------------------------------ Read permissions |
{ |
{ |
open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); |
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
Line 13069 BEGIN {
|
Line 13169 BEGIN {
|
|
|
# -------------------------------------------- Read plain texts for permissions |
# -------------------------------------------- Read plain texts for permissions |
{ |
{ |
open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab"); |
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
Line 13089 BEGIN {
|
Line 13189 BEGIN {
|
|
|
# ---------------------------------------------------------- Read package table |
# ---------------------------------------------------------- Read package table |
{ |
{ |
open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab"); |
|
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
if ($configline !~ /\S/ || $configline=~/^#/) { next; } |
if ($configline !~ /\S/ || $configline=~/^#/) { next; } |
Line 13135 BEGIN {
|
Line 13235 BEGIN {
|
# ---------------------------------------------------------- Read managers table |
# ---------------------------------------------------------- Read managers table |
{ |
{ |
if (-e "$perlvar{'lonTabDir'}/managers.tab") { |
if (-e "$perlvar{'lonTabDir'}/managers.tab") { |
if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { |
if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) { |
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
chomp($configline); |
chomp($configline); |
next if ($configline =~ /^\#/); |
next if ($configline =~ /^\#/); |