version 1.1142, 2011/11/07 18:27:19
|
version 1.1159, 2012/03/15 18:15:55
|
Line 595 sub transfer_profile_to_env {
|
Line 595 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) = @_; |
my ($r,$name) = @_; |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
my $lonid=$cookies{'lonID'}; |
if ($name eq '') { |
|
$name = 'lonID'; |
|
} |
|
my $lonid=$cookies{$name}; |
return undef if (!$lonid); |
return undef if (!$lonid); |
|
|
my $handle=&LONCAPA::clean_handle($lonid->value); |
my $handle=&LONCAPA::clean_handle($lonid->value); |
my $lonidsdir=$r->dir_config('lonIDsDir'); |
my $lonidsdir; |
|
if ($name eq 'lonDAV') { |
|
$lonidsdir=$r->dir_config('lonDAVsessDir'); |
|
} else { |
|
$lonidsdir=$r->dir_config('lonIDsDir'); |
|
} |
return undef if (!-e "$lonidsdir/$handle.id"); |
return undef if (!-e "$lonidsdir/$handle.id"); |
|
|
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
Line 930 sub choose_server {
|
Line 938 sub choose_server {
|
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
my %servers = &get_servers($udom); |
my %servers = &get_servers($udom); |
my $lowest_load = 30000; |
my $lowest_load = 30000; |
my ($login_host,$hostname,$portal_path); |
my ($login_host,$hostname,$portal_path,$isredirect); |
foreach my $lonhost (keys(%servers)) { |
foreach my $lonhost (keys(%servers)) { |
my $loginvia; |
my $loginvia; |
if ($checkloginvia) { |
if ($checkloginvia) { |
Line 941 sub choose_server {
|
Line 949 sub choose_server {
|
&compare_server_load($server, $login_host, $lowest_load); |
&compare_server_load($server, $login_host, $lowest_load); |
if ($login_host eq $server) { |
if ($login_host eq $server) { |
$portal_path = $path; |
$portal_path = $path; |
|
$isredirect = 1; |
} |
} |
} else { |
} else { |
($login_host, $lowest_load) = |
($login_host, $lowest_load) = |
&compare_server_load($lonhost, $login_host, $lowest_load); |
&compare_server_load($lonhost, $login_host, $lowest_load); |
if ($login_host eq $lonhost) { |
if ($login_host eq $lonhost) { |
$portal_path = ''; |
$portal_path = ''; |
|
$isredirect = ''; |
} |
} |
} |
} |
} else { |
} else { |
Line 957 sub choose_server {
|
Line 967 sub choose_server {
|
if ($login_host ne '') { |
if ($login_host ne '') { |
$hostname = &hostname($login_host); |
$hostname = &hostname($login_host); |
} |
} |
return ($login_host,$hostname,$portal_path); |
return ($login_host,$hostname,$portal_path,$isredirect); |
} |
} |
|
|
# --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
Line 1920 sub get_domain_defaults {
|
Line 1930 sub get_domain_defaults {
|
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$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'}; |
} 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 2798 sub resizeImage {
|
Line 2809 sub resizeImage {
|
# $resizewidth - width (pixels) to which to resize uploaded image |
# $resizewidth - width (pixels) to which to resize uploaded image |
# $resizeheight - height (pixels) to which to resize uploaded image |
# $resizeheight - height (pixels) to which to resize uploaded image |
# $mimetype - reference to scalar to accommodate mime type determined |
# $mimetype - reference to scalar to accommodate mime type determined |
# from File::MMagic if $parser = parse. |
# from File::MMagic. |
# |
# |
# output: url of file in userspace, or error: <message> |
# output: url of file in userspace, or error: <message> |
# or /adm/notfound.html if failure to upload occurse |
# or /adm/notfound.html if failure to upload occurse |
Line 2967 sub finishuserfileupload {
|
Line 2978 sub finishuserfileupload {
|
} |
} |
} |
} |
} |
} |
|
if (($context eq 'coursedoc') || ($parser eq 'parse')) { |
|
if (ref($mimetype)) { |
|
if ($$mimetype eq '') { |
|
my $mm = new File::MMagic; |
|
my $type = $mm->checktype_filename($filepath.'/'.$file); |
|
$$mimetype = $type; |
|
} |
|
} |
|
} |
if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
my $mm = new File::MMagic; |
if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { |
my $type = $mm->checktype_filename($filepath.'/'.$file); |
|
if ($type eq 'text/html') { |
|
my $parse_result = &extract_embedded_items($filepath.'/'.$file, |
my $parse_result = &extract_embedded_items($filepath.'/'.$file, |
$allfiles,$codebase); |
$allfiles,$codebase); |
unless ($parse_result eq 'ok') { |
unless ($parse_result eq 'ok') { |
Line 2978 sub finishuserfileupload {
|
Line 2996 sub finishuserfileupload {
|
' for embedded media: '.$parse_result); |
' for embedded media: '.$parse_result); |
} |
} |
} |
} |
if (ref($mimetype)) { |
|
$$mimetype = $type; |
|
} |
|
} |
} |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
my $input = $filepath.'/'.$file; |
my $input = $filepath.'/'.$file; |
Line 3251 sub flushcourselogs {
|
Line 3266 sub flushcourselogs {
|
my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); |
my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); |
if ($result eq 'ok') { |
if ($result eq 'ok') { |
delete $accesshash{$entry}; |
delete $accesshash{$entry}; |
} elsif ($result eq 'unknown_cmd') { |
|
# Target server has old code running on it. |
|
my %temphash=($entry => $value); |
|
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
|
delete $accesshash{$entry}; |
|
} |
|
} |
} |
} else { |
} else { |
my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); |
my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); |
|
if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; } |
my %temphash=($entry => $accesshash{$entry}); |
my %temphash=($entry => $accesshash{$entry}); |
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
delete $accesshash{$entry}; |
delete $accesshash{$entry}; |
Line 3338 sub courseacclog {
|
Line 3348 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|task|page)$/) { |
if ($fnsymb=~/$LONCAPA::assess_re/) { |
$what.=':POST'; |
$what.=':POST'; |
# FIXME: Probably ought to escape things.... |
# FIXME: Probably ought to escape things.... |
foreach my $key (keys(%env)) { |
foreach my $key (keys(%env)) { |
Line 3370 sub countacc {
|
Line 3380 sub countacc {
|
my $url=&declutter(shift); |
my $url=&declutter(shift); |
return if (! defined($url) || $url eq ''); |
return if (! defined($url) || $url eq ''); |
unless ($env{'request.course.id'}) { return ''; } |
unless ($env{'request.course.id'}) { return ''; } |
|
# |
|
# Mark that this url was used in this course |
|
# |
$accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; |
$accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; |
|
# |
|
# Increase the access count for this resource in this child process |
|
# |
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; |
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; |
$accesshash{$key}++; |
$accesshash{$key}++; |
} |
} |
Line 3537 sub get_my_roles {
|
Line 3553 sub get_my_roles {
|
foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
my ($role,$tend,$tstart); |
my ($role,$tend,$tstart); |
if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
|
next if ($entry =~ /^rolesdef/); |
($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); |
($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); |
} else { |
} else { |
($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
Line 3850 sub get_domain_roles {
|
Line 3867 sub get_domain_roles {
|
|
|
# ----------------------------------------------------------- Interval timing |
# ----------------------------------------------------------- Interval timing |
|
|
|
{ |
|
# Caches needed for speedup of navmaps |
|
# We don't want to cache this for very long at all (5 seconds at most) |
|
# |
|
# The user for whom we cache |
|
my $cachedkey=''; |
|
# The cached times for this user |
|
my %cachedtimes=(); |
|
# When this was last done |
|
my $cachedtime=(); |
|
|
|
sub load_all_first_access { |
|
my ($uname,$udom)=@_; |
|
if (($cachedkey eq $uname.':'.$udom) && |
|
(abs($cachedtime-time)<5)) { |
|
return; |
|
} |
|
$cachedtime=time; |
|
$cachedkey=$uname.':'.$udom; |
|
%cachedtimes=&dump('firstaccesstimes',$udom,$uname); |
|
} |
|
|
sub get_first_access { |
sub get_first_access { |
my ($type,$argsymb)=@_; |
my ($type,$argsymb)=@_; |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
Line 3862 sub get_first_access {
|
Line 3901 sub get_first_access {
|
} else { |
} else { |
$res=$symb; |
$res=$symb; |
} |
} |
my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); |
&load_all_first_access($uname,$udom); |
return $times{"$courseid\0$res"}; |
return $cachedtimes{"$courseid\0$res"}; |
} |
} |
|
|
sub set_first_access { |
sub set_first_access { |
Line 3877 sub set_first_access {
|
Line 3916 sub set_first_access {
|
} else { |
} else { |
$res=$symb; |
$res=$symb; |
} |
} |
|
$cachedkey=''; |
my $firstaccess=&get_first_access($type,$symb); |
my $firstaccess=&get_first_access($type,$symb); |
if (!$firstaccess) { |
if (!$firstaccess) { |
return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); |
return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); |
} |
} |
return 'already_set'; |
return 'already_set'; |
} |
} |
|
} |
# --------------------------------------------- Set Expire Date for Spreadsheet |
# --------------------------------------------- Set Expire Date for Spreadsheet |
|
|
sub expirespread { |
sub expirespread { |
Line 7514 sub modify_student_enrollment {
|
Line 7554 sub modify_student_enrollment {
|
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
} |
} |
my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); |
my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); |
|
my $user = "$uname:$udom"; |
|
my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); |
my $reply=cput('classlist', |
my $reply=cput('classlist', |
{"$uname:$udom" => |
{$user => |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
$cdom,$cnum); |
$cdom,$cnum); |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
if (($reply eq 'ok') || ($reply eq 'delayed')) { |
|
&devalidate_getsection_cache($udom,$uname,$cid); |
|
} else { |
return 'error: '.$reply; |
return 'error: '.$reply; |
} else { |
|
&devalidate_getsection_cache($udom,$uname,$cid); |
|
} |
} |
# Add student role to user |
# Add student role to user |
my $uurl='/'.$cid; |
my $uurl='/'.$cid; |
Line 7529 sub modify_student_enrollment {
|
Line 7571 sub modify_student_enrollment {
|
if ($usec) { |
if ($usec) { |
$uurl.='/'.$usec; |
$uurl.='/'.$usec; |
} |
} |
return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context); |
my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef, |
|
$selfenroll,$context); |
|
if ($result ne 'ok') { |
|
if ($old_entry{$user} ne '') { |
|
$reply = &cput('classlist',\%old_entry,$cdom,$cnum); |
|
} else { |
|
$reply = &del('classlist',[$user],$cdom,$cnum); |
|
} |
|
} |
|
return $result; |
} |
} |
|
|
sub format_name { |
sub format_name { |
Line 8709 sub EXT {
|
Line 8760 sub EXT {
|
} elsif ($realm eq 'request') { |
} elsif ($realm eq 'request') { |
# ------------------------------------------------------------- request.browser |
# ------------------------------------------------------------- request.browser |
if ($space eq 'browser') { |
if ($space eq 'browser') { |
if ($qualifier eq 'textremote') { |
return $env{'browser.'.$qualifier}; |
if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') { |
|
return 1; |
|
} else { |
|
return 0; |
|
} |
|
} else { |
|
return $env{'browser.'.$qualifier}; |
|
} |
|
# ------------------------------------------------------------ request.filename |
# ------------------------------------------------------------ request.filename |
} else { |
} else { |
return $env{'request.'.$spacequalifierrest}; |
return $env{'request.'.$spacequalifierrest}; |
Line 9362 sub gettitle {
|
Line 9405 sub gettitle {
|
} |
} |
$title=~s/\&colon\;/\:/gs; |
$title=~s/\&colon\;/\:/gs; |
if ($title) { |
if ($title) { |
|
# Remember both $symb and $title for dynamic metadata |
|
$accesshash{$symb.'___crstitle'}=$title; |
|
# Cache this title and then return it |
return &do_cache_new('title',$key,$title,600); |
return &do_cache_new('title',$key,$title,600); |
} |
} |
$urlsymb=$url; |
$urlsymb=$url; |
Line 9394 sub get_slot {
|
Line 9440 sub get_slot {
|
} |
} |
return $slotinfo{$which}; |
return $slotinfo{$which}; |
} |
} |
|
|
|
sub get_reservable_slots { |
|
my ($cnum,$cdom,$uname,$udom) = @_; |
|
my $now = time; |
|
my $reservable_info; |
|
my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom); |
|
if (exists($remembered{$key})) { |
|
$reservable_info = $remembered{$key}; |
|
} else { |
|
my %resv; |
|
($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) = |
|
&Apache::loncommon::get_future_slots($cnum,$cdom,$now); |
|
$reservable_info = \%resv; |
|
$remembered{$key} = $reservable_info; |
|
} |
|
return $reservable_info; |
|
} |
|
|
|
sub get_course_slots { |
|
my ($cnum,$cdom) = @_; |
|
my $hashid=$cnum.':'.$cdom; |
|
my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid); |
|
if (defined($cached)) { |
|
if (ref($result) eq 'HASH') { |
|
return %{$result}; |
|
} |
|
} else { |
|
my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); |
|
my ($tmp) = keys(%slots); |
|
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
|
&Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600); |
|
return %slots; |
|
} |
|
} |
|
return; |
|
} |
|
|
|
sub devalidate_slots_cache { |
|
my ($cnum,$cdom)=@_; |
|
my $hashid=$cnum.':'.$cdom; |
|
&devalidate_cache_new('allslots',$hashid); |
|
} |
|
|
# ------------------------------------------------- Update symbolic store links |
# ------------------------------------------------- Update symbolic store links |
|
|
sub symblist { |
sub symblist { |
Line 9759 sub rndseed {
|
Line 9848 sub rndseed {
|
if (!defined($symb)) { |
if (!defined($symb)) { |
unless ($symb=$wsymb) { return time; } |
unless ($symb=$wsymb) { return time; } |
} |
} |
if (!$courseid) { $courseid=$wcourseid; } |
if (!defined $courseid) { |
if (!$domain) { $domain=$wdomain; } |
$courseid=$wcourseid; |
if (!$username) { $username=$wusername } |
} |
|
if (!defined $domain) { $domain=$wdomain; } |
|
if (!defined $username) { $username=$wusername } |
|
|
my $which; |
my $which; |
if (defined($cenv->{'rndseed'})) { |
if (defined($cenv->{'rndseed'})) { |
Line 9769 sub rndseed {
|
Line 9860 sub rndseed {
|
} else { |
} else { |
$which =&get_rand_alg($courseid); |
$which =&get_rand_alg($courseid); |
} |
} |
|
|
if (defined(&getCODE())) { |
if (defined(&getCODE())) { |
|
|
if ($which eq '64bit5') { |
if ($which eq '64bit5') { |
Line 10276 sub hreflocation {
|
Line 10366 sub hreflocation {
|
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { |
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { |
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--; |
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--; |
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { |
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { |
$file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ |
$file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/} |
-/uploaded/$1/$2/-x; |
{/uploaded/$1/$2/}x; |
} |
} |
if ($file=~ m{^/userfiles/}) { |
if ($file=~ m{^/userfiles/}) { |
$file =~ s{^/userfiles/}{/uploaded/}; |
$file =~ s{^/userfiles/}{/uploaded/}; |