|
version 1.349, 2003/03/24 18:18:09
|
version 1.412, 2003/09/15 18:43:54
|
|
Line 75 use vars
|
Line 75 use vars
|
| qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
| %libserv %pr %prp %metacache %packagetab %titlecache |
%libserv %pr %prp %metacache %packagetab %titlecache |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursehombuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache |
| %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); |
%domaindescription %domain_auth_def %domain_auth_arg_def |
| |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); |
| |
|
| use IO::Socket; |
use IO::Socket; |
| use GDBM_File; |
use GDBM_File; |
| use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
|
Line 244 sub critical {
|
Line 246 sub critical {
|
| return $answer; |
return $answer; |
| } |
} |
| |
|
| |
# |
| |
# -------------- Remove all key from the env that start witha lowercase letter |
| |
# (Which is always a lon-capa value) |
| |
|
| |
sub cleanenv { |
| |
# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; } |
| |
# unless (&Apache::exists_config_define("MODPERL2")) { return; } |
| |
foreach my $key (keys(%ENV)) { |
| |
if ($key =~ /^[a-z]/) { |
| |
delete($ENV{$key}); |
| |
} |
| |
} |
| |
} |
| |
|
| |
# ------------------------------------------- Transfer profile into environment |
| |
|
| |
sub transfer_profile_to_env { |
| |
my ($lonidsdir,$handle)=@_; |
| |
my @profile; |
| |
{ |
| |
my $idf=Apache::File->new("$lonidsdir/$handle.id"); |
| |
flock($idf,LOCK_SH); |
| |
@profile=<$idf>; |
| |
$idf->close(); |
| |
} |
| |
my $envi; |
| |
for ($envi=0;$envi<=$#profile;$envi++) { |
| |
chomp($profile[$envi]); |
| |
my ($envname,$envvalue)=split(/=/,$profile[$envi]); |
| |
$ENV{$envname} = $envvalue; |
| |
} |
| |
$ENV{'user.environment'} = "$lonidsdir/$handle.id"; |
| |
} |
| |
|
| # ---------------------------------------------------------- Append Environment |
# ---------------------------------------------------------- Append Environment |
| |
|
| sub appenv { |
sub appenv { |
|
Line 347 sub delenv {
|
Line 383 sub delenv {
|
| return 'ok'; |
return 'ok'; |
| } |
} |
| |
|
| |
# ------------------------------------------ Find out current server userload |
| |
# there is a copy in lond |
| |
sub userload { |
| |
my $numusers=0; |
| |
{ |
| |
opendir(LONIDS,$perlvar{'lonIDsDir'}); |
| |
my $filename; |
| |
my $curtime=time; |
| |
while ($filename=readdir(LONIDS)) { |
| |
if ($filename eq '.' || $filename eq '..') {next;} |
| |
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; |
| |
if ($curtime-$mtime < 3600) { $numusers++; } |
| |
} |
| |
closedir(LONIDS); |
| |
} |
| |
my $userloadpercent=0; |
| |
my $maxuserload=$perlvar{'lonUserLoadLim'}; |
| |
if ($maxuserload) { |
| |
$userloadpercent=100*$numusers/$maxuserload; |
| |
} |
| |
$userloadpercent=sprintf("%.2f",$userloadpercent); |
| |
return $userloadpercent; |
| |
} |
| |
|
| # ------------------------------------------ Fight off request when overloaded |
# ------------------------------------------ Fight off request when overloaded |
| |
|
| sub overloaderror { |
sub overloaderror { |
|
Line 373 sub overloaderror {
|
Line 433 sub overloaderror {
|
| # ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
| |
|
| sub spareserver { |
sub spareserver { |
| my $loadpercent = shift; |
my ($loadpercent,$userloadpercent) = @_; |
| my $tryserver; |
my $tryserver; |
| my $spareserver=''; |
my $spareserver=''; |
| my $lowestserver=$loadpercent; |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
| |
my $lowestserver=$loadpercent > $userloadpercent? |
| |
$loadpercent : $userloadpercent; |
| foreach $tryserver (keys %spareid) { |
foreach $tryserver (keys %spareid) { |
| my $answer=reply('load',$tryserver); |
my $loadans=reply('load',$tryserver); |
| if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
my $userloadans=reply('userload',$tryserver); |
| $spareserver="http://$hostname{$tryserver}"; |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
| $lowestserver=$answer; |
next; #didn't get a number from the server |
| } |
} |
| } |
my $answer; |
| |
if ($loadans =~ /\d/) { |
| |
if ($userloadans =~ /\d/) { |
| |
#both are numbers, pick the bigger one |
| |
$answer=$loadans > $userloadans? |
| |
$loadans : $userloadans; |
| |
} else { |
| |
$answer = $loadans; |
| |
} |
| |
} else { |
| |
$answer = $userloadans; |
| |
} |
| |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
| |
$spareserver="http://$hostname{$tryserver}"; |
| |
$lowestserver=$answer; |
| |
} |
| |
} |
| return $spareserver; |
return $spareserver; |
| } |
} |
| |
|
|
Line 591 sub idput {
|
Line 669 sub idput {
|
| # --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
| |
|
| sub assign_access_key { |
sub assign_access_key { |
| my ($ckey,$cdom,$cnum,$udom,$uname)=@_; |
# |
| |
# a valid key looks like uname:udom#comments |
| |
# comments are being appended |
| |
# |
| |
my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_; |
| $cdom= |
$cdom= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| $cnum= |
$cnum= |
|
Line 599 sub assign_access_key {
|
Line 681 sub assign_access_key {
|
| $udom=$ENV{'user.name'} unless (defined($udom)); |
$udom=$ENV{'user.name'} unless (defined($udom)); |
| $uname=$ENV{'user.domain'} unless (defined($uname)); |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
| my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
| if (($existing{$ckey}=~/^\d+$/) || # has time - new key |
if (($existing{$ckey}=~/^\#(.*)$/) || # - new key |
| ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen, |
($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { |
| |
# assigned to this person |
| |
# - this should not happen, |
| # unless something went wrong |
# unless something went wrong |
| # the first time around |
# the first time around |
| # ready to assign |
# ready to assign |
| } elsif (!$existing{$ckey}) { |
$logentry=$1.'; '.$logentry; |
| if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') { |
if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry}, |
| |
$cdom,$cnum) eq 'ok') { |
| # key now belongs to user |
# key now belongs to user |
| my $envkey='key.'.$cdom.'_'.$cnum; |
my $envkey='key.'.$cdom.'_'.$cnum; |
| if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
|
Line 618 sub assign_access_key {
|
Line 703 sub assign_access_key {
|
| } else { |
} else { |
| return 'error: Could not assign key, try again later.'; |
return 'error: Could not assign key, try again later.'; |
| } |
} |
| |
} elsif (!$existing{$ckey}) { |
| # the key does not exist |
# the key does not exist |
| return 'error: The key does not exist'; |
return 'error: The key does not exist'; |
| } else { |
} else { |
|
Line 626 sub assign_access_key {
|
Line 712 sub assign_access_key {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------ put an additional comment on a key |
| |
|
| |
sub comment_access_key { |
| |
# |
| |
# a valid key looks like uname:udom#comments |
| |
# comments are being appended |
| |
# |
| |
my ($ckey,$cdom,$cnum,$logentry)=@_; |
| |
$cdom= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| |
$cnum= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
| |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
| |
if ($existing{$ckey}) { |
| |
$existing{$ckey}.='; '.$logentry; |
| |
# ready to assign |
| |
if (&put('accesskeys',{$ckey=>$existing{$ckey}}, |
| |
$cdom,$cnum) eq 'ok') { |
| |
return 'ok'; |
| |
} else { |
| |
return 'error: Count not store comment.'; |
| |
} |
| |
} else { |
| |
# the key does not exist |
| |
return 'error: The key does not exist'; |
| |
} |
| |
} |
| |
|
| # ------------------------------------------------------ Generate a set of keys |
# ------------------------------------------------------ Generate a set of keys |
| |
|
| sub generate_access_keys { |
sub generate_access_keys { |
| my ($number,$cdom,$cnum)=@_; |
my ($number,$cdom,$cnum,$logentry)=@_; |
| $cdom= |
$cdom= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| $cnum= |
$cnum= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
| unless (&allowed('ccc',$cdom)) { return 0; } |
unless (&allowed('mky',$cdom)) { return 0; } |
| unless (($cdom) && ($cnum)) { return 0; } |
unless (($cdom) && ($cnum)) { return 0; } |
| if ($number>10000) { return 0; } |
if ($number>10000) { return 0; } |
| sleep(2); # make sure don't get same seed twice |
sleep(2); # make sure don't get same seed twice |
|
Line 650 sub generate_access_keys {
|
Line 764 sub generate_access_keys {
|
| if ($existing{$newkey}) { |
if ($existing{$newkey}) { |
| $i--; |
$i--; |
| } else { |
} else { |
| if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') { |
if (&put('accesskeys', |
| |
{ $newkey => '# generated '.localtime(). |
| |
' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. |
| |
'; '.$logentry }, |
| |
$cdom,$cnum) eq 'ok') { |
| $total++; |
$total++; |
| } |
} |
| } |
} |
|
Line 671 sub validate_access_key {
|
Line 789 sub validate_access_key {
|
| $udom=$ENV{'user.name'} unless (defined($udom)); |
$udom=$ENV{'user.name'} unless (defined($udom)); |
| $uname=$ENV{'user.domain'} unless (defined($uname)); |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
| my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
| return ($existing{$ckey} eq $uname.':'.$udom); |
return ($existing{$ckey}=~/^$uname\:$udom\#/); |
| } |
} |
| |
|
| # ------------------------------------- Find the section of student in a course |
# ------------------------------------- Find the section of student in a course |
|
Line 892 sub repcopy {
|
Line 1010 sub repcopy {
|
| |
|
| # ------------------------------------------------ Get server side include body |
# ------------------------------------------------ Get server side include body |
| sub ssi_body { |
sub ssi_body { |
| my $filelink=shift; |
my ($filelink,%form)=@_; |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
| &ssi($filelink)); |
&ssi($filelink,%form)); |
| $output=~s/^.*\<body[^\>]*\>//si; |
$output=~s/^.*\<body[^\>]*\>//si; |
| $output=~s/\<\/body\s*\>.*$//si; |
$output=~s/\<\/body\s*\>.*$//si; |
| $output=~ |
$output=~ |
|
Line 1027 sub log {
|
Line 1145 sub log {
|
| } |
} |
| |
|
| # ------------------------------------------------------------------ Course Log |
# ------------------------------------------------------------------ Course Log |
| |
# |
| |
# This routine flushes several buffers of non-mission-critical nature |
| |
# |
| |
|
| sub flushcourselogs { |
sub flushcourselogs { |
| &logthis('Flushing course log buffers'); |
&logthis('Flushing log buffers'); |
| |
# |
| |
# course logs |
| |
# This is a log of all transactions in a course, which can be used |
| |
# for data mining purposes |
| |
# |
| |
# It also collects the courseid database, which lists last transaction |
| |
# times and course titles for all courseids |
| |
# |
| |
my %courseidbuffer=(); |
| foreach (keys %courselogs) { |
foreach (keys %courselogs) { |
| my $crsid=$_; |
my $crsid=$_; |
| if (&reply('log:'.$coursedombuf{$crsid}.':'. |
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. |
| &escape($courselogs{$crsid}), |
&escape($courselogs{$crsid}), |
| $coursehombuf{$crsid}) eq 'ok') { |
$coursehombuf{$crsid}) eq 'ok') { |
| delete $courselogs{$crsid}; |
delete $courselogs{$crsid}; |
|
Line 1043 sub flushcourselogs {
|
Line 1173 sub flushcourselogs {
|
| " exceeded maximum size, deleting.</font>"); |
" exceeded maximum size, deleting.</font>"); |
| delete $courselogs{$crsid}; |
delete $courselogs{$crsid}; |
| } |
} |
| } |
} |
| |
if ($courseidbuffer{$coursehombuf{$crsid}}) { |
| |
$courseidbuffer{$coursehombuf{$crsid}}.='&'. |
| |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}); |
| |
} else { |
| |
$courseidbuffer{$coursehombuf{$crsid}}= |
| |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}); |
| |
} |
| } |
} |
| &logthis('Flushing access logs'); |
# |
| |
# Write course id database (reverse lookup) to homeserver of courses |
| |
# Is used in pickcourse |
| |
# |
| |
foreach (keys %courseidbuffer) { |
| |
&courseidput($hostdom{$_},$courseidbuffer{$_},$_); |
| |
} |
| |
# |
| |
# File accesses |
| |
# Writes to the dynamic metadata of resources to get hit counts, etc. |
| |
# |
| foreach (keys %accesshash) { |
foreach (keys %accesshash) { |
| my $entry=$_; |
my $entry=$_; |
| $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; |
$entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; |
|
Line 1054 sub flushcourselogs {
|
Line 1201 sub flushcourselogs {
|
| delete $accesshash{$entry}; |
delete $accesshash{$entry}; |
| } |
} |
| } |
} |
| &logthis('Flushing role logs'); |
# |
| |
# Roles |
| |
# Reverse lookup of user roles for course faculty/staff and co-authorship |
| |
# |
| foreach (keys %userrolehash) { |
foreach (keys %userrolehash) { |
| my $entry=$_; |
my $entry=$_; |
| my ($role,$uname,$udom,$runame,$rudom)= |
my ($role,$uname,$udom,$runame,$rudom,$rsec)= |
| split(/\:/,$entry); |
split(/\:/,$entry); |
| if (&Apache::lonnet::put('nohist_userroles', |
if (&Apache::lonnet::put('nohist_userroles', |
| { $role.':'.$uname.':'.$udom => $userrolehash{$entry} }, |
{ $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, |
| $rudom,$runame) eq 'ok') { |
$rudom,$runame) eq 'ok') { |
| delete $userrolehash{$entry}; |
delete $userrolehash{$entry}; |
| } |
} |
|
Line 1073 sub courselog {
|
Line 1223 sub courselog {
|
| $what=time.':'.$what; |
$what=time.':'.$what; |
| unless ($ENV{'request.course.id'}) { return ''; } |
unless ($ENV{'request.course.id'}) { return ''; } |
| $coursedombuf{$ENV{'request.course.id'}}= |
$coursedombuf{$ENV{'request.course.id'}}= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; |
| |
$coursenumbuf{$ENV{'request.course.id'}}= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; |
| $coursehombuf{$ENV{'request.course.id'}}= |
$coursehombuf{$ENV{'request.course.id'}}= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
| |
$coursedescrbuf{$ENV{'request.course.id'}}= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
| if (defined $courselogs{$ENV{'request.course.id'}}) { |
if (defined $courselogs{$ENV{'request.course.id'}}) { |
| $courselogs{$ENV{'request.course.id'}}.='&'.$what; |
$courselogs{$ENV{'request.course.id'}}.='&'.$what; |
| } else { |
} else { |
|
Line 1091 sub courseacclog {
|
Line 1244 sub courseacclog {
|
| my $fnsymb=shift; |
my $fnsymb=shift; |
| unless ($ENV{'request.course.id'}) { return ''; } |
unless ($ENV{'request.course.id'}) { return ''; } |
| my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; |
my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; |
| if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) { |
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { |
| $what.=':POST'; |
$what.=':POST'; |
| foreach (keys %ENV) { |
foreach (keys %ENV) { |
| if ($_=~/^form\.(.*)/) { |
if ($_=~/^form\.(.*)/) { |
|
Line 1114 sub countacc {
|
Line 1267 sub countacc {
|
| } |
} |
| } |
} |
| |
|
| |
sub linklog { |
| |
my ($from,$to)=@_; |
| |
$from=&declutter($from); |
| |
$to=&declutter($to); |
| |
$accesshash{$from.'___'.$to.'___comefrom'}=1; |
| |
$accesshash{$to.'___'.$from.'___goto'}=1; |
| |
} |
| |
|
| sub userrolelog { |
sub userrolelog { |
| my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
| if (($trole=~/^ca/) || ($trole=~/^in/) || |
if (($trole=~/^ca/) || ($trole=~/^in/) || |
| ($trole=~/^cc/) || ($trole=~/^ep/) || |
($trole=~/^cc/) || ($trole=~/^ep/) || |
| ($trole=~/^cr/)) { |
($trole=~/^cr/)) { |
| my (undef,$rudom,$runame)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| $userrolehash{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom} |
$userrolehash |
| |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
| =$tend.':'.$tstart; |
=$tend.':'.$tstart; |
| } |
} |
| } |
} |
| |
|
| |
sub get_course_adv_roles { |
| |
my $cid=shift; |
| |
$cid=$ENV{'request.course.id'} unless (defined($cid)); |
| |
my %coursehash=&coursedescription($cid); |
| |
my %returnhash=(); |
| |
my %dumphash= |
| |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
| |
my $now=time; |
| |
foreach (keys %dumphash) { |
| |
my ($tend,$tstart)=split(/\:/,$dumphash{$_}); |
| |
if (($tstart) && ($tstart<0)) { next; } |
| |
if (($tend) && ($tend<$now)) { next; } |
| |
if (($tstart) && ($now<$tstart)) { next; } |
| |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
| |
my $key=&plaintext($role); |
| |
if ($section) { $key.=' (Sec/Grp '.$section.')'; } |
| |
if ($returnhash{$key}) { |
| |
$returnhash{$key}.=','.$username.':'.$domain; |
| |
} else { |
| |
$returnhash{$key}=$username.':'.$domain; |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
sub get_my_roles { |
| |
my ($uname,$udom)=@_; |
| |
unless (defined($uname)) { $uname=$ENV{'user.name'}; } |
| |
unless (defined($udom)) { $udom=$ENV{'user.domain'}; } |
| |
my %dumphash= |
| |
&dump('nohist_userroles',$udom,$uname); |
| |
my %returnhash=(); |
| |
my $now=time; |
| |
foreach (keys %dumphash) { |
| |
my ($tend,$tstart)=split(/\:/,$dumphash{$_}); |
| |
if (($tstart) && ($tstart<0)) { next; } |
| |
if (($tend) && ($tend<$now)) { next; } |
| |
if (($tstart) && ($now<$tstart)) { next; } |
| |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
| |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
# ----------------------------------------------------- Frontpage Announcements |
| |
# |
| |
# |
| |
|
| |
sub postannounce { |
| |
my ($server,$text)=@_; |
| |
unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } |
| |
unless ($text=~/\w/) { $text=''; } |
| |
return &reply('setannounce:'.&escape($text),$server); |
| |
} |
| |
|
| |
sub getannounce { |
| |
if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { |
| |
my $announcement=''; |
| |
while (<$fh>) { $announcement .=$_; } |
| |
$fh->close(); |
| |
if ($announcement=~/\w/) { |
| |
return |
| |
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. |
| |
'<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>'; |
| |
} else { |
| |
return ''; |
| |
} |
| |
} else { |
| |
return ''; |
| |
} |
| |
} |
| |
|
| |
# ---------------------------------------------------------- Course ID routines |
| |
# Deal with domain's nohist_courseid.db files |
| |
# |
| |
|
| |
sub courseidput { |
| |
my ($domain,$what,$coursehome)=@_; |
| |
return &reply('courseidput:'.$domain.':'.$what,$coursehome); |
| |
} |
| |
|
| |
sub courseiddump { |
| |
my ($domfilter,$descfilter,$sincefilter)=@_; |
| |
my %returnhash=(); |
| |
unless ($domfilter) { $domfilter=''; } |
| |
foreach my $tryserver (keys %libserv) { |
| |
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
| |
foreach ( |
| |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
| |
$sincefilter.':'.&escape($descfilter), |
| |
$tryserver))) { |
| |
my ($key,$value)=split(/\=/,$_); |
| |
if (($key) && ($value)) { |
| |
$returnhash{&unescape($key)}=&unescape($value); |
| |
} |
| |
} |
| |
|
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
# |
| # ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Check out an item |
| |
|
| sub checkout { |
sub checkout { |
|
Line 1234 sub devalidate {
|
Line 1500 sub devalidate {
|
| my ($symb,$uname,$udom)=@_; |
my ($symb,$uname,$udom)=@_; |
| my $cid=$ENV{'request.course.id'}; |
my $cid=$ENV{'request.course.id'}; |
| if ($cid) { |
if ($cid) { |
| # delete the stored spreadsheets for |
# delete the stored spreadsheets for |
| # - the student level sheet of this user in course's homespace |
# - the student level sheet of this user in course's homespace |
| # - the assessment level sheet for this resource |
# - the assessment level sheet for this resource |
| # for this user in user's homespace |
# for this user in user's homespace |
| my $key=$uname.':'.$udom.':'; |
my $key=$uname.':'.$udom.':'; |
| my $status= |
my $status= |
| &del('nohist_calculatedsheets', |
&del('nohist_calculatedsheets', |
| [$key.'studentcalc'], |
[$key.'studentcalc:'], |
| $ENV{'course.'.$cid.'.domain'}, |
$ENV{'course.'.$cid.'.domain'}, |
| $ENV{'course.'.$cid.'.num'}) |
$ENV{'course.'.$cid.'.num'}) |
| .' '. |
.' '. |
| &del('nohist_calculatedsheets_'.$cid, |
&del('nohist_calculatedsheets_'.$cid, |
| [$key.'assesscalc:'.$symb]); |
[$key.'assesscalc:'.$symb],$udom,$uname); |
| unless ($status eq 'ok ok') { |
unless ($status eq 'ok ok') { |
| &logthis('Could not devalidate spreadsheet '. |
&logthis('Could not devalidate spreadsheet '. |
| $uname.' at '.$udom.' for '. |
$uname.' at '.$udom.' for '. |
|
Line 1452 sub tmpreset {
|
Line 1718 sub tmpreset {
|
| my ($symb,$namespace,$domain,$stuname) = @_; |
my ($symb,$namespace,$domain,$stuname) = @_; |
| if (!$symb) { |
if (!$symb) { |
| $symb=&symbread(); |
$symb=&symbread(); |
| if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } |
if (!$symb) { $symb= $ENV{'request.url'}; } |
| } |
} |
| $symb=escape($symb); |
$symb=escape($symb); |
| |
|
|
Line 1745 sub rolesinit {
|
Line 2011 sub rolesinit {
|
| my ($tdummy,$tdomain,$trest)=split(/\//,$area); |
my ($tdummy,$tdomain,$trest)=split(/\//,$area); |
| if ($trole =~ /^cr\//) { |
if ($trole =~ /^cr\//) { |
| my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
| my $homsvr=homeserver($rauthor,$rdomain); |
my $homsvr=homeserver($rauthor,$rdomain); |
| if ($hostname{$homsvr} ne '') { |
if ($hostname{$homsvr} ne '') { |
| my $roledef= |
my ($rdummy,$roledef)= |
| reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", |
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
| $homsvr); |
|
| if (($roledef ne 'con_lost') && ($roledef ne '')) { |
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
| my ($syspriv,$dompriv,$coursepriv)= |
my ($syspriv,$dompriv,$coursepriv)= |
| split(/\_/,unescape($roledef)); |
split(/\_/,$roledef); |
| if (defined($syspriv)) { |
if (defined($syspriv)) { |
| $allroles{'cm./'}.=':'.$syspriv; |
$allroles{'cm./'}.=':'.$syspriv; |
| $allroles{$spec.'./'}.=':'.$syspriv; |
$allroles{$spec.'./'}.=':'.$syspriv; |
|
Line 1886 sub dump {
|
Line 2152 sub dump {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
# -------------------------------------------------------------- keys interface |
| |
|
| |
sub getkeys { |
| |
my ($namespace,$udomain,$uname)=@_; |
| |
if (!$udomain) { $udomain=$ENV{'user.domain'}; } |
| |
if (!$uname) { $uname=$ENV{'user.name'}; } |
| |
my $uhome=&homeserver($uname,$udomain); |
| |
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); |
| |
my @keyarray=(); |
| |
foreach (split(/\&/,$rep)) { |
| |
push (@keyarray,&unescape($_)); |
| |
} |
| |
return @keyarray; |
| |
} |
| |
|
| # --------------------------------------------------------------- currentdump |
# --------------------------------------------------------------- currentdump |
| sub currentdump { |
sub currentdump { |
| my ($courseid,$sdom,$sname)=@_; |
my ($courseid,$sdom,$sname)=@_; |
|
Line 2018 sub customaccess {
|
Line 2299 sub customaccess {
|
| $access=($effect eq 'allow'); |
$access=($effect eq 'allow'); |
| last; |
last; |
| } |
} |
| |
if ($realm eq '' && $role eq '') { |
| |
$access=($effect eq 'allow'); |
| |
} |
| } |
} |
| return $access; |
return $access; |
| } |
} |
|
Line 2030 sub allowed {
|
Line 2314 sub allowed {
|
| my $orguri=$uri; |
my $orguri=$uri; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| |
|
| |
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=~/\.meta$/)) && ($priv eq 'bre')) { |
if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
|
Line 2330 sub is_on_map {
|
Line 2615 sub is_on_map {
|
| sub definerole { |
sub definerole { |
| if (allowed('mcr','/')) { |
if (allowed('mcr','/')) { |
| my ($rolename,$sysrole,$domrole,$courole)=@_; |
my ($rolename,$sysrole,$domrole,$courole)=@_; |
| foreach (split('/',$sysrole)) { |
foreach (split(':',$sysrole)) { |
| my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$_); |
| if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } |
if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } |
| if ($pr{'cr:s'}=~/$crole\&/) { |
if ($pr{'cr:s'}=~/$crole\&/) { |
|
Line 2339 sub definerole {
|
Line 2624 sub definerole {
|
| } |
} |
| } |
} |
| } |
} |
| foreach (split('/',$domrole)) { |
foreach (split(':',$domrole)) { |
| my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$_); |
| if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } |
if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } |
| if ($pr{'cr:d'}=~/$crole\&/) { |
if ($pr{'cr:d'}=~/$crole\&/) { |
|
Line 2348 sub definerole {
|
Line 2633 sub definerole {
|
| } |
} |
| } |
} |
| } |
} |
| foreach (split('/',$courole)) { |
foreach (split(':',$courole)) { |
| my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$_); |
| if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } |
if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } |
| if ($pr{'cr:c'}=~/$crole\&/) { |
if ($pr{'cr:c'}=~/$crole\&/) { |
|
Line 2457 sub plaintext {
|
Line 2742 sub plaintext {
|
| # ----------------------------------------------------------------- Assign Role |
# ----------------------------------------------------------------- Assign Role |
| |
|
| sub assignrole { |
sub assignrole { |
| my ($udom,$uname,$url,$role,$end,$start)=@_; |
my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; |
| my $mrole; |
my $mrole; |
| if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
| unless (&allowed('ccr',$url)) { |
my $cwosec=$url; |
| |
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; |
| |
unless (&allowed('ccr',$cwosec)) { |
| &logthis('Refused custom assignrole: '. |
&logthis('Refused custom assignrole: '. |
| $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
| $ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
|
Line 2470 sub assignrole {
|
Line 2757 sub assignrole {
|
| } else { |
} else { |
| my $cwosec=$url; |
my $cwosec=$url; |
| $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; |
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; |
| unless (&allowed('c'.$role,$cwosec)) { |
unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { |
| &logthis('Refused assignrole: '. |
&logthis('Refused assignrole: '. |
| $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
| $ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
$ENV{'user.name'}.' at '.$ENV{'user.domain'}); |
|
Line 2488 sub assignrole {
|
Line 2775 sub assignrole {
|
| $command.='_0_'.$start; |
$command.='_0_'.$start; |
| } |
} |
| } |
} |
| |
# actually delete |
| |
if ($deleteflag) { |
| |
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { |
| |
# modify command to delete the role |
| |
$command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". |
| |
"$udom:$uname:$url".'_'."$mrole"; |
| |
&logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); |
| |
# set start and finish to negative values for userrolelog |
| |
$start=-1; |
| |
$end=-1; |
| |
} |
| |
} |
| |
# send command |
| my $answer=&reply($command,&homeserver($uname,$udom)); |
my $answer=&reply($command,&homeserver($uname,$udom)); |
| |
# log new user role if status is ok |
| if ($answer eq 'ok') { |
if ($answer eq 'ok') { |
| &userrolelog($mrole,$uname,$udom,$url,$start,$end); |
&userrolelog($mrole,$uname,$udom,$url,$start,$end); |
| } |
} |
|
Line 2527 sub modifyuser {
|
Line 2828 sub modifyuser {
|
| my ($udom, $uname, $uid, |
my ($udom, $uname, $uid, |
| $umode, $upass, $first, |
$umode, $upass, $first, |
| $middle, $last, $gene, |
$middle, $last, $gene, |
| $forceid, $desiredhome)=@_; |
$forceid, $desiredhome, $email)=@_; |
| $udom=~s/\W//g; |
$udom=~s/\W//g; |
| $uname=~s/\W//g; |
$uname=~s/\W//g; |
| &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
|
Line 2539 sub modifyuser {
|
Line 2840 sub modifyuser {
|
| ' in domain '.$ENV{'request.role.domain'}); |
' in domain '.$ENV{'request.role.domain'}); |
| my $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
| # ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
| if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
if (($uhome eq 'no_host') && |
| |
(($umode && $upass) || ($umode eq 'localauth'))) { |
| my $unhome=''; |
my $unhome=''; |
| if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
| $unhome = $desiredhome; |
$unhome = $desiredhome; |
|
Line 2569 sub modifyuser {
|
Line 2871 sub modifyuser {
|
| } |
} |
| $uhome=&homeserver($uname,$udom,'true'); |
$uhome=&homeserver($uname,$udom,'true'); |
| if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
| return 'error: verify home'; |
return 'error: unable verify users home machine.'; |
| } |
} |
| } # End of creation of new user |
} # End of creation of new user |
| # ---------------------------------------------------------------------- Add ID |
# ---------------------------------------------------------------------- Add ID |
|
Line 2579 sub modifyuser {
|
Line 2881 sub modifyuser {
|
| if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) |
if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) |
| && (!$forceid)) { |
&& (!$forceid)) { |
| unless ($uid eq $uidhash{$uname}) { |
unless ($uid eq $uidhash{$uname}) { |
| return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; |
return 'error: user id "'.$uid.'" does not match '. |
| |
'current user id "'.$uidhash{$uname}.'".'; |
| } |
} |
| } else { |
} else { |
| &idput($udom,($uname => $uid)); |
&idput($udom,($uname => $uid)); |
|
Line 2595 sub modifyuser {
|
Line 2898 sub modifyuser {
|
| } else { |
} else { |
| %names = @tmp; |
%names = @tmp; |
| } |
} |
| |
# |
| |
# Make sure to not trash student environment if instructor does not bother |
| |
# to supply name and email information |
| |
# |
| if ($first) { $names{'firstname'} = $first; } |
if ($first) { $names{'firstname'} = $first; } |
| if ($middle) { $names{'middlename'} = $middle; } |
if (defined($middle)) { $names{'middlename'} = $middle; } |
| if ($last) { $names{'lastname'} = $last; } |
if ($last) { $names{'lastname'} = $last; } |
| if ($gene) { $names{'generation'} = $gene; } |
if (defined($gene)) { $names{'generation'} = $gene; } |
| |
if ($email) { $names{'notification'} = $email; |
| |
$names{'critnotification'} = $email; } |
| |
|
| my $reply = &put('environment', \%names, $udom,$uname); |
my $reply = &put('environment', \%names, $udom,$uname); |
| if ($reply ne 'ok') { return 'error: '.$reply; } |
if ($reply ne 'ok') { return 'error: '.$reply; } |
| &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
|
Line 2612 sub modifyuser {
|
Line 2922 sub modifyuser {
|
| |
|
| sub modifystudent { |
sub modifystudent { |
| my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
| $end,$start,$forceid,$desiredhome)=@_; |
$end,$start,$forceid,$desiredhome,$email)=@_; |
| my $cid=''; |
my $cid=''; |
| unless ($cid=$ENV{'request.course.id'}) { |
unless ($cid=$ENV{'request.course.id'}) { |
| return 'not_in_class'; |
return 'not_in_class'; |
|
Line 2620 sub modifystudent {
|
Line 2930 sub modifystudent {
|
| # --------------------------------------------------------------- Make the user |
# --------------------------------------------------------------- Make the user |
| my $reply=&modifyuser |
my $reply=&modifyuser |
| ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
| $desiredhome); |
$desiredhome,$email); |
| unless ($reply eq 'ok') { return $reply; } |
unless ($reply eq 'ok') { return $reply; } |
| # This will cause &modify_student_enrollment to get the uid from the |
# This will cause &modify_student_enrollment to get the uid from the |
| # students environment |
# students environment |
|
Line 2738 sub createcourse {
|
Line 3048 sub createcourse {
|
| return 'error: no such course'; |
return 'error: no such course'; |
| } |
} |
| # ----------------------------------------------------------------- Course made |
# ----------------------------------------------------------------- Course made |
| |
# log existance |
| |
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), |
| |
$uhome); |
| |
&flushcourselogs(); |
| |
# set toplevel url |
| my $topurl=$url; |
my $topurl=$url; |
| unless ($nonstandard) { |
unless ($nonstandard) { |
| # ------------------------------------------ For standard courses, make top url |
# ------------------------------------------ For standard courses, make top url |
|
Line 2766 ENDINITMAP
|
Line 3081 ENDINITMAP
|
| # ---------------------------------------------------------- Assign Custom Role |
# ---------------------------------------------------------- Assign Custom Role |
| |
|
| sub assigncustomrole { |
sub assigncustomrole { |
| my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; |
| return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, |
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, |
| $end,$start); |
$end,$start,$deleteflag); |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Revoke Role |
# ----------------------------------------------------------------- Revoke Role |
| |
|
| sub revokerole { |
sub revokerole { |
| my ($udom,$uname,$url,$role)=@_; |
my ($udom,$uname,$url,$role,$deleteflag)=@_; |
| my $now=time; |
my $now=time; |
| return &assignrole($udom,$uname,$url,$role,$now); |
return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); |
| } |
} |
| |
|
| # ---------------------------------------------------------- Revoke Custom Role |
# ---------------------------------------------------------- Revoke Custom Role |
| |
|
| sub revokecustomrole { |
sub revokecustomrole { |
| my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; |
| my $now=time; |
my $now=time; |
| return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); |
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, |
| |
$deleteflag); |
| } |
} |
| |
|
| # ------------------------------------------------------------ Directory lister |
# ------------------------------------------------------------ Directory lister |
|
Line 2849 sub dirlist {
|
Line 3165 sub dirlist {
|
| } |
} |
| my $alldomstr=''; |
my $alldomstr=''; |
| foreach (sort keys %alldom) { |
foreach (sort keys %alldom) { |
| $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; |
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; |
| } |
} |
| $alldomstr=~s/:$//; |
$alldomstr=~s/:$//; |
| return split(/:/,$alldomstr); |
return split(/:/,$alldomstr); |
|
Line 2865 sub dirlist {
|
Line 3181 sub dirlist {
|
| # when it was last modified. It will also return an error of -1 |
# when it was last modified. It will also return an error of -1 |
| # if an error occurs |
# if an error occurs |
| |
|
| |
## |
| |
## FIXME: This subroutine assumes its caller knows something about the |
| |
## directory structure of the home server for the student ($root). |
| |
## Not a good assumption to make. Since this is for looking up files |
| |
## in user directories, the full path should be constructed by lond, not |
| |
## whatever machine we request data from. |
| |
## |
| sub GetFileTimestamp { |
sub GetFileTimestamp { |
| my ($studentDomain,$studentName,$filename,$root)=@_; |
my ($studentDomain,$studentName,$filename,$root)=@_; |
| $studentDomain=~s/\W//g; |
$studentDomain=~s/\W//g; |
|
Line 2873 sub GetFileTimestamp {
|
Line 3196 sub GetFileTimestamp {
|
| $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
| my $proname="$studentDomain/$subdir/$studentName"; |
my $proname="$studentDomain/$subdir/$studentName"; |
| $proname .= '/'.$filename; |
$proname .= '/'.$filename; |
| my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName, |
my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, |
| $root); |
$studentName, $root); |
| my $fileStat = $dir[0]; |
|
| my @stats = split('&', $fileStat); |
my @stats = split('&', $fileStat); |
| if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
| return $stats[9]; |
# @stats contains first the filename, then the stat output |
| |
return $stats[10]; # so this is 10 instead of 9. |
| } else { |
} else { |
| return -1; |
return -1; |
| } |
} |
|
Line 2974 sub courseresdata {
|
Line 3297 sub courseresdata {
|
| return undef; |
return undef; |
| } |
} |
| |
|
| # --------------------------------------------------------- Value of a Variable |
# |
| |
# EXT resource caching routines |
| |
# |
| |
|
| |
sub clear_EXT_cache_status { |
| |
&delenv('cache.EXT.'); |
| |
} |
| |
|
| |
sub EXT_cache_status { |
| |
my ($target_domain,$target_user) = @_; |
| |
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
| |
if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { |
| |
# We know already the user has no data |
| |
return 1; |
| |
} else { |
| |
return 0; |
| |
} |
| |
} |
| |
|
| |
sub EXT_cache_set { |
| |
my ($target_domain,$target_user) = @_; |
| |
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
| |
&appenv($cachename => time); |
| |
} |
| |
|
| |
# --------------------------------------------------------- Value of a Variable |
| sub EXT { |
sub EXT { |
| my ($varname,$symbparm,$udom,$uname,)=@_; |
my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; |
| |
|
| unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
| #get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
| my $courseid; |
my $courseid; |
| |
my $publicuser; |
| if (!($uname && $udom)) { |
if (!($uname && $udom)) { |
| (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
(my $cursymb,$courseid,$udom,$uname,$publicuser)= |
| |
&Apache::lonxml::whichuser($symbparm); |
| if (!$symbparm) { $symbparm=$cursymb; } |
if (!$symbparm) { $symbparm=$cursymb; } |
| } else { |
} else { |
| $courseid=$ENV{'request.course.id'}; |
$courseid=$ENV{'request.course.id'}; |
|
Line 3006 sub EXT {
|
Line 3355 sub EXT {
|
| if (defined($Apache::lonhomework::parsing_a_problem)) { |
if (defined($Apache::lonhomework::parsing_a_problem)) { |
| return $Apache::lonhomework::history{$qualifierrest}; |
return $Apache::lonhomework::history{$qualifierrest}; |
| } else { |
} else { |
| my %restored=&restore($symbparm,$courseid,$udom,$uname); |
my %restored; |
| |
if ($publicuser || $ENV{'request.state'} eq 'construct') { |
| |
%restored=&tmprestore($symbparm,$courseid,$udom,$uname); |
| |
} else { |
| |
%restored=&restore($symbparm,$courseid,$udom,$uname); |
| |
} |
| return $restored{$qualifierrest}; |
return $restored{$qualifierrest}; |
| } |
} |
| # ----------------------------------------------------------------- user.access |
# ----------------------------------------------------------------- user.access |
|
Line 3019 sub EXT {
|
Line 3373 sub EXT {
|
| ($udom eq $ENV{'user.domain'})) { |
($udom eq $ENV{'user.domain'})) { |
| return $ENV{join('.',('environment',$qualifierrest))}; |
return $ENV{join('.',('environment',$qualifierrest))}; |
| } else { |
} else { |
| my %returnhash=&userenvironment($udom,$uname,$qualifierrest); |
my %returnhash; |
| |
if (!$publicuser) { |
| |
%returnhash=&userenvironment($udom,$uname, |
| |
$qualifierrest); |
| |
} |
| return $returnhash{$qualifierrest}; |
return $returnhash{$qualifierrest}; |
| } |
} |
| # ----------------------------------------------------------------- user.course |
# ----------------------------------------------------------------- user.course |
|
Line 3043 sub EXT {
|
Line 3401 sub EXT {
|
| return $uname; |
return $uname; |
| # ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
| } else { |
} else { |
| my %reply=&get($space,[$qualifierrest],$udom,$uname); |
my %reply; |
| return $reply{$qualifierrest}; |
if (!$publicuser) { |
| |
%reply=&get($space,[$qualifierrest],$udom,$uname); |
| |
} |
| |
return $reply{$qualifierrest}; |
| } |
} |
| } elsif ($realm eq 'query') { |
} elsif ($realm eq 'query') { |
| # ---------------------------------------------- pull stuff out of query string |
# ---------------------------------------------- pull stuff out of query string |
| &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]); |
&Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, |
| return $ENV{'form.'.$space}; |
[$spacequalifierrest]); |
| |
return $ENV{'form.'.$spacequalifierrest}; |
| } elsif ($realm eq 'request') { |
} elsif ($realm eq 'request') { |
| # ------------------------------------------------------------- request.browser |
# ------------------------------------------------------------- request.browser |
| if ($space eq 'browser') { |
if ($space eq 'browser') { |
|
Line 3063 sub EXT {
|
Line 3425 sub EXT {
|
| return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; |
return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; |
| } elsif ($realm eq 'resource') { |
} elsif ($realm eq 'resource') { |
| |
|
| if ($courseid eq $ENV{'request.course.id'}) { |
my $section; |
| |
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { |
| |
|
| #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
| |
|
| # ----------------------------------------------------- Cascading lookup scheme |
# ----------------------------------------------------- Cascading lookup scheme |
| if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
| my $symbp=$symbparm; |
my $symbp=$symbparm; |
| my $mapp=(split(/\_\_\_/,$symbp))[0]; |
my $mapp=(&decode_symb($symbp))[0]; |
| |
|
| my $symbparm=$symbp.'.'.$spacequalifierrest; |
my $symbparm=$symbp.'.'.$spacequalifierrest; |
| my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
| |
|
| my $section; |
|
| if (($ENV{'user.name'} eq $uname) && |
if (($ENV{'user.name'} eq $uname) && |
| ($ENV{'user.domain'} eq $udom)) { |
($ENV{'user.domain'} eq $udom)) { |
| $section=$ENV{'request.course.sec'}; |
$section=$ENV{'request.course.sec'}; |
| } else { |
} else { |
| $section=&usection($udom,$uname,$courseid); |
if (! defined($usection)) { |
| |
$section=&usection($udom,$uname,$courseid); |
| |
} else { |
| |
$section = $usection; |
| |
} |
| } |
} |
| |
|
| my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
|
Line 3092 sub EXT {
|
Line 3458 sub EXT {
|
| my $courselevelm=$courseid.'.'.$mapparm; |
my $courselevelm=$courseid.'.'.$mapparm; |
| |
|
| # ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
| #most student don't have any data set, check if there is some data |
#most student don\'t have any data set, check if there is some data |
| #every thirty minutes |
#every thirty minutes |
| if (! |
if (! &EXT_cache_status($udom,$uname)) { |
| (exists($ENV{'cache.studentresdata'}) |
|
| && (($ENV{'cache.studentresdata'}+1800) > time))) { |
|
| my %resourcedata=&get('resourcedata', |
my %resourcedata=&get('resourcedata', |
| [$courselevelr,$courselevelm,$courselevel], |
[$courselevelr,$courselevelm,$courselevel], |
| $udom,$uname); |
$udom,$uname); |
|
Line 3115 sub EXT {
|
Line 3479 sub EXT {
|
| $uname." at ".$udom.": ". |
$uname." at ".$udom.": ". |
| $tmp."</font>"); |
$tmp."</font>"); |
| } elsif ($tmp=~/error:No such file/) { |
} elsif ($tmp=~/error:No such file/) { |
| $ENV{'cache.studentresdata'}=time; |
&EXT_cache_set($udom,$uname); |
| &appenv(('cache.studentresdata'=> |
|
| $ENV{'cache.studentresdata'})); |
|
| } elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| return $tmp; |
return $tmp; |
| } |
} |
|
Line 3150 sub EXT {
|
Line 3512 sub EXT {
|
| my $filename; |
my $filename; |
| if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
| if ($symbparm) { |
if ($symbparm) { |
| $filename=(split(/\_\_\_/,$symbparm))[2]; |
$filename=(&decode_symb($symbparm))[2]; |
| } else { |
} else { |
| $filename=$ENV{'request.filename'}; |
$filename=$ENV{'request.filename'}; |
| } |
} |
|
Line 3166 sub EXT {
|
Line 3528 sub EXT {
|
| my $part=join('_',@parts); |
my $part=join('_',@parts); |
| if ($part eq '') { $part='0'; } |
if ($part eq '') { $part='0'; } |
| my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
| $symbparm,$udom,$uname); |
$symbparm,$udom,$uname,$section,1); |
| if (defined($partgeneral)) { return $partgeneral; } |
if (defined($partgeneral)) { return $partgeneral; } |
| } |
} |
| |
if ($recurse) { return undef; } |
| |
my $pack_def=&packages_tab_default($filename,$varname); |
| |
if (defined($pack_def)) { return $pack_def; } |
| |
|
| # ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
| } elsif ($realm eq 'environment') { |
} elsif ($realm eq 'environment') { |
|
Line 3189 sub EXT {
|
Line 3554 sub EXT {
|
| return ''; |
return ''; |
| } |
} |
| |
|
| |
sub packages_tab_default { |
| |
my ($uri,$varname)=@_; |
| |
my (undef,$part,$name)=split(/\./,$varname); |
| |
my $packages=&metadata($uri,'packages'); |
| |
foreach my $package (split(/,/,$packages)) { |
| |
my ($pack_type,$pack_part)=split(/_/,$package,2); |
| |
if ($pack_part eq $part) { |
| |
return $packagetab{"$pack_type&$name&default"}; |
| |
} |
| |
} |
| |
return undef; |
| |
} |
| |
|
| sub add_prefix_and_part { |
sub add_prefix_and_part { |
| my ($prefix,$part)=@_; |
my ($prefix,$part)=@_; |
| my $keyroot; |
my $keyroot; |
|
Line 3230 sub metadata {
|
Line 3608 sub metadata {
|
| if ($liburi) { |
if ($liburi) { |
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
| } |
} else { |
| |
delete($metacache{$uri.':packages'}); |
| |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring=&getfile(&filelocation('',&clutter($filename))); |
my $metastring=&getfile(&filelocation('',&clutter($filename))); |
|
Line 3256 sub metadata {
|
Line 3636 sub metadata {
|
| foreach (keys %packagetab) { |
foreach (keys %packagetab) { |
| if ($_=~/^$package\&/) { |
if ($_=~/^$package\&/) { |
| my ($pack,$name,$subp)=split(/\&/,$_); |
my ($pack,$name,$subp)=split(/\&/,$_); |
| |
# ignore package.tab specified default values |
| |
# here &package_tab_default() will fetch those |
| |
if ($subp eq 'default') { next; } |
| my $value=$packagetab{$_}; |
my $value=$packagetab{$_}; |
| my $part=$keyroot; |
my $part=$keyroot; |
| $part=~s/^\_//; |
$part=~s/^\_//; |
|
Line 3263 sub metadata {
|
Line 3646 sub metadata {
|
| $value.=' [Part: '.$part.']'; |
$value.=' [Part: '.$part.']'; |
| } |
} |
| my $unikey='parameter'.$keyroot.'_'.$name; |
my $unikey='parameter'.$keyroot.'_'.$name; |
| if ($subp eq 'default') { $unikey='parameter_0_'.$name; } |
|
| $metathesekeys{$unikey}=1; |
|
| $metacache{$uri.':'.$unikey.'.part'}=$part; |
$metacache{$uri.':'.$unikey.'.part'}=$part; |
| |
$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
| $metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
$metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri.':'.$unikey.'.default'})) { |
if (defined($metacache{$uri.':'.$unikey.'.default'})) { |
| $metacache{$uri.':'.$unikey}= |
$metacache{$uri.':'.$unikey}= |
| $metacache{$uri.':'.$unikey.'.default'} |
$metacache{$uri.':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| } |
} |
| } else { |
} else { |
|
Line 3368 sub metadata_generate_part0 {
|
Line 3750 sub metadata_generate_part0 {
|
| if ($metakey=~/^parameter\_(.*)/) { |
if ($metakey=~/^parameter\_(.*)/) { |
| my $part=$$metacache{$uri.':'.$metakey.'.part'}; |
my $part=$$metacache{$uri.':'.$metakey.'.part'}; |
| my $name=$$metacache{$uri.':'.$metakey.'.name'}; |
my $name=$$metacache{$uri.':'.$metakey.'.name'}; |
| if (! exists($$metadata{'parameter_0_'.$name})) { |
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { |
| $allnames{$name}=$part; |
$allnames{$name}=$part; |
| } |
} |
| } |
} |
|
Line 3398 sub gettitle {
|
Line 3780 sub gettitle {
|
| unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
| return &metadata($urlsymb,'title'); |
return &metadata($urlsymb,'title'); |
| } |
} |
| if ($titlecache{$symb}) { return $titlecache{$symb}; } |
if ($titlecache{$symb}) { |
| my ($map,$resid,$url)=split(/\_\_\_/,$symb); |
if (time < ($titlecache{$symb}[1] + 600)) { |
| |
return $titlecache{$symb}[0]; |
| |
} else { |
| |
delete($titlecache{$symb}); |
| |
} |
| |
} |
| |
my ($map,$resid,$url)=&decode_symb($symb); |
| my $title=''; |
my $title=''; |
| my %bighash; |
my %bighash; |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
|
Line 3408 sub gettitle {
|
Line 3796 sub gettitle {
|
| $title=$bighash{'title_'.$mapid.'.'.$resid}; |
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
| untie %bighash; |
untie %bighash; |
| } |
} |
| |
$title=~s/\&colon\;/\:/gs; |
| if ($title) { |
if ($title) { |
| $titlecache{$symb}=$title; |
$titlecache{$symb}=[$title,time]; |
| return $title; |
return $title; |
| } else { |
} else { |
| return &metadata($urlsymb,'title'); |
return &metadata($urlsymb,'title'); |
|
Line 3444 sub symbverify {
|
Line 3833 sub symbverify {
|
| # direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
| if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
| # check URL part |
# check URL part |
| my ($map,$resid,$url)=split(/\_\_\_/,$symb); |
my ($map,$resid,$url)=&decode_symb($symb); |
| unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } |
unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } |
| |
|
| $symb=&symbclean($symb); |
$symb=&symbclean($symb); |
|
Line 3487 sub symbclean {
|
Line 3876 sub symbclean {
|
| return $symb; |
return $symb; |
| } |
} |
| |
|
| |
# ---------------------------------------------- Split symb to find map and url |
| |
|
| |
sub decode_symb { |
| |
return split(/\_\_\_/,shift); |
| |
} |
| |
|
| # ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
| |
|
| sub symbread { |
sub symbread { |
|
Line 3581 sub numval {
|
Line 3976 sub numval {
|
| $txt=~tr/u-z/0-5/; |
$txt=~tr/u-z/0-5/; |
| $txt=~s/\D//g; |
$txt=~s/\D//g; |
| return int($txt); |
return int($txt); |
| } |
} |
| |
|
| |
sub latest_rnd_algorithm_id { |
| |
return '64bit'; |
| |
} |
| |
|
| sub rndseed { |
sub rndseed { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| |
|
| |
my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); |
| if (!$symb) { |
if (!$symb) { |
| unless ($symb=&symbread()) { return time; } |
unless ($symb=$wsymb) { return time; } |
| } |
} |
| if (!$courseid) { $courseid=$ENV{'request.course.id'};} |
if (!$courseid) { $courseid=$wcourseid; } |
| if (!$domain) {$domain=$ENV{'user.domain'};} |
if (!$domain) { $domain=$wdomain; } |
| if (!$username) {$username=$ENV{'user.name'};} |
if (!$username) { $username=$wusername } |
| |
my $which=$ENV{"course.$courseid.rndseed"}; |
| |
my $CODE=$ENV{'scantron.CODE'}; |
| |
if (defined($CODE)) { |
| |
&rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
| |
} elsif ($which eq '64bit') { |
| |
return &rndseed_64bit($symb,$courseid,$domain,$username); |
| |
} |
| |
return &rndseed_32bit($symb,$courseid,$domain,$username); |
| |
} |
| |
|
| |
sub rndseed_32bit { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| { |
{ |
| use integer; |
use integer; |
| my $symbchck=unpack("%32C*",$symb) << 27; |
my $symbchck=unpack("%32C*",$symb) << 27; |
| my $symbseed=numval($symb) << 22; |
my $symbseed=numval($symb) << 22; |
| my $namechck=unpack("%32C*",$username) << 17; |
my $namechck=unpack("%32C*",$username) << 17; |
| my $nameseed=numval($username) << 12; |
my $nameseed=numval($username) << 12; |
| my $domainseed=unpack("%32C*",$domain) << 7; |
my $domainseed=unpack("%32C*",$domain) << 7; |
| my $courseseed=unpack("%32C*",$courseid); |
my $courseseed=unpack("%32C*",$courseid); |
| my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
| #uncommenting these lines can break things! |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
| #&Apache::lonxml::debug("rndseed :$num:$symb"); |
return $num; |
| return $num; |
} |
| |
} |
| |
|
| |
sub rndseed_64bit { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| |
{ |
| |
use integer; |
| |
my $symbchck=unpack("%32S*",$symb) << 21; |
| |
my $symbseed=numval($symb) << 10; |
| |
my $namechck=unpack("%32S*",$username); |
| |
|
| |
my $nameseed=numval($username) << 21; |
| |
my $domainseed=unpack("%32S*",$domain) << 10; |
| |
my $courseseed=unpack("%32S*",$courseid); |
| |
|
| |
my $num1=$symbchck+$symbseed+$namechck; |
| |
my $num2=$nameseed+$domainseed+$courseseed; |
| |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
| |
return "$num1,$num2"; |
| |
} |
| |
} |
| |
|
| |
sub rndseed_CODE_64bit { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| |
{ |
| |
use integer; |
| |
my $symbchck=unpack("%32S*",$symb) << 16; |
| |
my $symbseed=numval($symb); |
| |
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
| |
my $courseseed=unpack("%32S*",$courseid); |
| |
my $num1=$symbseed+$CODEseed; |
| |
my $num2=$courseseed+$symbchck; |
| |
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); |
| |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
| |
return "$num1,$num2"; |
| |
} |
| |
} |
| |
|
| |
sub setup_random_from_rndseed { |
| |
my ($rndseed)=@_; |
| |
if ($rndseed =~/,/) { |
| |
my ($num1,$num2)=split(/,/,$rndseed); |
| |
&Math::Random::random_set_seed(abs($num1),abs($num2)); |
| |
} else { |
| |
&Math::Random::random_set_seed_from_phrase($rndseed); |
| } |
} |
| } |
} |
| |
|
|
Line 3729 sub goodbye {
|
Line 4187 sub goodbye {
|
| &logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
| &flushcourselogs(); |
&flushcourselogs(); |
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| |
return DONE; |
| } |
} |
| |
|
| BEGIN { |
BEGIN { |
|
Line 3766 BEGIN {
|
Line 4225 BEGIN {
|
| %domain_auth_arg_def = (); |
%domain_auth_arg_def = (); |
| if ($fh) { |
if ($fh) { |
| while (<$fh>) { |
while (<$fh>) { |
| next if /^\#/; |
next if (/^(\#|\s*$)/); |
| |
# next if /^\#/; |
| chomp; |
chomp; |
| my ($domain, $domain_description, $def_auth, $def_auth_arg) |
my ($domain, $domain_description, $def_auth, $def_auth_arg, |
| = split(/:/,$_,4); |
$def_lang, $city, $longi, $lati) = split(/:/,$_); |
| $domain_auth_def{$domain}=$def_auth; |
$domain_auth_def{$domain}=$def_auth; |
| $domain_auth_arg_def{$domain}=$def_auth_arg; |
$domain_auth_arg_def{$domain}=$def_auth_arg; |
| $domaindescription{$domain}=$domain_description; |
$domaindescription{$domain}=$domain_description; |
| |
$domain_lang_def{$domain}=$def_lang; |
| |
$domain_city{$domain}=$city; |
| |
$domain_longi{$domain}=$longi; |
| |
$domain_lati{$domain}=$lati; |
| |
|
| # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
| # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
| } |
} |
|
Line 3909 being set.
|
Line 4374 being set.
|
| |
|
| =back |
=back |
| |
|
| =head1 INTRODUCTION |
=head1 OVERVIEW |
| |
|
| This module provides subroutines which interact with the |
lonnet provides subroutines which interact with the |
| lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about |
lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask |
| - classes |
about classes, users, and resources. |
| - users |
|
| - resources |
|
| |
|
| For many of these objects you can also use this to store data about |
For many of these objects you can also use this to store data about |
| them or modify them in various ways. |
them or modify them in various ways. |
| |
|
| This is part of the LearningOnline Network with CAPA project |
=head2 Symbs |
| described at http://www.lon-capa.org. |
|
| |
|
| =head1 RETURN MESSAGES |
To identify a specific instance of a resource, LON-CAPA uses symbols |
| |
or "symbs"X<symb>. These identifiers are built from the URL of the |
| |
map, the resource number of the resource in the map, and the URL of |
| |
the resource itself. The latter is somewhat redundant, but might help |
| |
if maps change. |
| |
|
| =over 4 |
An example is |
| |
|
| =item * |
msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem |
| |
|
| con_lost : unable to contact remote host |
The respective map entry is |
| |
|
| =item * |
<resource id="19" src="/res/msu/korte/tests/part12.problem" |
| |
title="Problem 2"> |
| |
</resource> |
| |
|
| con_delayed : unable to contact remote host, message will be delivered |
Symbs are used by the random number generator, as well as to store and |
| when the connection is brought back up |
restore data specific to a certain instance of for example a problem. |
| |
|
| =item * |
=head2 Storing And Retrieving Data |
| |
|
| con_failed : unable to contact remote host and unable to save message |
X<store()>X<cstore()>X<restore()>Three of the most important functions |
| for later delivery |
in C<lonnet.pm> are C<&Apache::lonnet::cstore()>, |
| |
C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which |
| |
is is the non-critical message twin of cstore. These functions are for |
| |
handlers to store a perl hash to a user's permanent data space in an |
| |
easy manner, and to retrieve it again on another call. It is expected |
| |
that a handler would use this once at the beginning to retrieve data, |
| |
and then again once at the end to send only the new data back. |
| |
|
| =item * |
The data is stored in the user's data directory on the user's |
| |
homeserver under the ID of the course. |
| |
|
| error: : an error a occured, a description of the error follows the : |
The hash that is returned by restore will have all of the previous |
| |
value for all of the elements of the hash. |
| |
|
| =item * |
Example: |
| |
|
| |
#creating a hash |
| |
my %hash; |
| |
$hash{'foo'}='bar'; |
| |
|
| |
#storing it |
| |
&Apache::lonnet::cstore(\%hash); |
| |
|
| |
#changing a value |
| |
$hash{'foo'}='notbar'; |
| |
|
| |
#adding a new value |
| |
$hash{'bar'}='foo'; |
| |
&Apache::lonnet::cstore(\%hash); |
| |
|
| |
#retrieving the hash |
| |
my %history=&Apache::lonnet::restore(); |
| |
|
| |
#print the hash |
| |
foreach my $key (sort(keys(%history))) { |
| |
print("\%history{$key} = $history{$key}"); |
| |
} |
| |
|
| no_such_host : unable to fund a host associated with the user/domain |
Will print out: |
| |
|
| |
%history{1:foo} = bar |
| |
%history{1:keys} = foo:timestamp |
| |
%history{1:timestamp} = 990455579 |
| |
%history{2:bar} = foo |
| |
%history{2:foo} = notbar |
| |
%history{2:keys} = foo:bar:timestamp |
| |
%history{2:timestamp} = 990455580 |
| |
%history{bar} = foo |
| |
%history{foo} = notbar |
| |
%history{timestamp} = 990455580 |
| |
%history{version} = 2 |
| |
|
| |
Note that the special hash entries C<keys>, C<version> and |
| |
C<timestamp> were added to the hash. C<version> will be equal to the |
| |
total number of versions of the data that have been stored. The |
| |
C<timestamp> attribute will be the UNIX time the hash was |
| |
stored. C<keys> is available in every historical section to list which |
| |
keys were added or changed at a specific historical revision of a |
| |
hash. |
| |
|
| |
B<Warning>: do not store the hash that restore returns directly. This |
| |
will cause a mess since it will restore the historical keys as if the |
| |
were new keys. I.E. 1:foo will become 1:1:foo etc. |
| |
|
| |
Calling convention: |
| |
|
| |
my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); |
| |
&Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); |
| |
|
| |
For more detailed information, see lonnet specific documentation. |
| |
|
| |
=head1 RETURN MESSAGES |
| |
|
| |
=over 4 |
| |
|
| |
=item * B<con_lost>: unable to contact remote host |
| |
|
| |
=item * B<con_delayed>: unable to contact remote host, message will be delivered |
| |
when the connection is brought back up |
| |
|
| |
=item * B<con_failed>: unable to contact remote host and unable to save message |
| |
for later delivery |
| |
|
| |
=item * B<error:>: an error a occured, a description of the error follows the : |
| |
|
| |
=item * B<no_such_host>: unable to fund a host associated with the user/domain |
| that was requested |
that was requested |
| |
|
| =back |
=back |
|
Line 3958 that was requested
|
Line 4503 that was requested
|
| |
|
| =over 4 |
=over 4 |
| |
|
| =item * |
=item * |
| |
X<appenv()> |
| appenv(%hash) : the value of %hash is written to the user envirnoment |
B<appenv(%hash)>: the value of %hash is written to |
| file, and will be restored for each access this user makes during this |
the user envirnoment file, and will be restored for each access this |
| session, also modifies the %ENV for the current process |
user makes during this session, also modifies the %ENV for the current |
| |
process |
| |
|
| =item * |
=item * |
| |
X<delenv()> |
| delenv($regexp) : removes all items from the session environment file that matches the regular expression in $regexp. The values are also delted from the current processes %ENV. |
B<delenv($regexp)>: removes all items from the session |
| |
environment file that matches the regular expression in $regexp. The |
| |
values are also delted from the current processes %ENV. |
| |
|
| =back |
=back |
| |
|
|
Line 3975 delenv($regexp) : removes all items from
|
Line 4523 delenv($regexp) : removes all items from
|
| =over 4 |
=over 4 |
| |
|
| =item * |
=item * |
| |
X<queryauthenticate()> |
| queryauthenticate($uname,$udom) : try to determine user's current |
B<queryauthenticate($uname,$udom)>: try to determine user's current |
| authentication scheme |
authentication scheme |
| |
|
| =item * |
=item * |
| |
X<authenticate()> |
| authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib |
B<authenticate($uname,$upass,$udom)>: try to |
| servers (first use the current one), $upass should be the users password |
authenticate user from domain's lib servers (first use the current |
| |
one). C<$upass> should be the users password. |
| |
|
| =item * |
=item * |
| |
X<homeserver()> |
| homeserver($uname,$udom) : find the server which has the user's |
B<homeserver($uname,$udom)>: find the server which has |
| directory and files (there must be only one), this caches the answer, |
the user's directory and files (there must be only one), this caches |
| and also caches if there is a borken connection. |
the answer, and also caches if there is a borken connection. |
| |
|
| =item * |
=item * |
| |
X<idget()> |
| idget($udom,@ids) : find the usernames behind a list of IDs (IDs are a |
B<idget($udom,@ids)>: find the usernames behind a list of IDs |
| unique resource in a domain, there must be only 1 ID per username, and |
(IDs are a unique resource in a domain, there must be only 1 ID per |
| only 1 username per ID in a specific domain) (returns hash: |
username, and only 1 username per ID in a specific domain) (returns |
| id=>name,id=>name) |
hash: id=>name,id=>name) |
| |
|
| =item * |
=item * |
| |
X<idrget()> |
| idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash: |
B<idrget($udom,@unames)>: find the IDs behind a list of |
| name=>id,name=>id) |
usernames (returns hash: name=>id,name=>id) |
| |
|
| =item * |
=item * |
| |
X<idput()> |
| idput($udom,%ids) : store away a list of names and associated IDs |
B<idput($udom,%ids)>: store away a list of names and associated IDs |
| |
|
| =item * |
=item * |
| |
X<rolesinit()> |
| rolesinit($udom,$username,$authhost) : get user privileges |
B<rolesinit($udom,$username,$authhost)>: get user privileges |
| |
|
| =item * |
=item * |
| |
X<usection()> |
| usection($udom,$uname,$cname) : finds the section of student in the |
B<usection($udom,$uname,$cname)>: finds the section of student in the |
| course $cname, return section name/number or '' for "not in course" |
course $cname, return section name/number or '' for "not in course" |
| and '-1' for "no section" |
and '-1' for "no section" |
| |
|
| =item * |
=item * |
| |
X<userenvironment()> |
| userenvironment($udom,$uname,@what) : gets the values of the keys |
B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
| passed in @what from the requested user's environment, returns a hash |
passed in @what from the requested user's environment, returns a hash |
| |
|
| =back |
=back |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl