loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1223 and 1.1252

version 1.1223, 2013/05/21 18:57:45	version 1.1252, 2014/03/09 15:39:04
Line 78 use Image::Magick;	Line 78 use Image::Magick;

use Encode;	use Encode;

use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache	use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease	$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab);	%managerstab);

Line 356 sub get_remote_globals {	Line 356 sub get_remote_globals {
}	}

sub remote_devalidate_cache {	sub remote_devalidate_cache {
my ($lonhost,$name,$id) = @_;	my ($lonhost,$cachekeys) = @_;
my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);	my $items;
	return unless (ref($cachekeys) eq 'ARRAY');
	my $cachestr = join('&',@{$cachekeys});
	my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
return $response;	return $response;
}	}

Line 603 sub transfer_profile_to_env {	Line 606 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) = @_;	my ($r,$name,$userhashref) = @_;
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 634 sub check_for_valid_session {	Line 637 sub check_for_valid_session {
\|\| !defined($disk_env{'user.domain'})) {	\|\| !defined($disk_env{'user.domain'})) {
return undef;	return undef;
}	}
if (($r->user() eq '') && ($apache >= 2.4)) {
if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {	if (ref($userhashref) eq 'HASH') {
$r->user($disk_env{'user.name'});	$userhashref->{'name'} = $disk_env{'user.name'};
} else {	$userhashref->{'domain'} = $disk_env{'user.domain'};
$r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});
}
}	}

return $handle;	return $handle;
}	}

Line 674 sub appenv {	Line 676 sub appenv {
if (($key =~ /^user\.role/) \|\| ($key =~ /^user\.priv/)) {	if (($key =~ /^user\.role/) \|\| ($key =~ /^user\.priv/)) {
$refused = 1;	$refused = 1;
if (ref($roles) eq 'ARRAY') {	if (ref($roles) eq 'ARRAY') {
my ($type,$role) = ($key =~ /^user\.(role\|priv)\.([^.]+)\./);	my ($type,$role) = ($key =~ m{^user\.(role\|priv)\.(.+?)\./});
if (grep(/^\Q$role\E$/,@{$roles})) {	if (grep(/^\Q$role\E$/,@{$roles})) {
$refused = 0;	$refused = 0;
}	}
Line 1323 sub check_loadbalancing {	Line 1325 sub check_loadbalancing {
}	}
}	}
} elsif (($homeintdom) && ($udom ne $serverhomedom)) {	} elsif (($homeintdom) && ($udom ne $serverhomedom)) {
my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);	($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
unless (defined($cached)) {	unless (defined($cached)) {
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);	&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
Line 1578 sub idput {	Line 1580 sub idput {
}	}
}	}

	# ---------------------------------------- Delete unwanted IDs from ids.db file

	sub iddel {
	my ($udom,$idshashref,$uhome)=@_;
	my %result=();
	unless (ref($idshashref) eq 'HASH') {
	return %result;
	}
	my %servers=();
	while (my ($id,$uname) = each(%{$idshashref})) {
	my $uhom;
	if ($uhome) {
	$uhom = $uhome;
	} else {
	$uhom=&homeserver($uname,$udom);
	}
	if ($uhom ne 'no_host') {
	if ($servers{$uhom}) {
	$servers{$uhom}.='&'.&escape($id);
	} else {
	$servers{$uhom}=&escape($id);
	}
	}
	}
	foreach my $server (keys(%servers)) {
	$result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
	}
	return %result;
	}

# ------------------------------dump from db file owned by domainconfig user	# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {	sub dump_dom {
my ($namespace, $udom, $regexp) = @_;	my ($namespace, $udom, $regexp) = @_;
Line 1954 sub inst_userrules {	Line 1986 sub inst_userrules {
# ------------- Get Authentication, Language and User Tools Defaults for Domain	# ------------- Get Authentication, Language and User Tools Defaults for Domain

sub get_domain_defaults {	sub get_domain_defaults {
my ($domain) = @_;	my ($domain,$ignore_cache) = @_;
	return if (($domain eq '') \|\| ($domain eq 'public'));
my $cachetime = 606024;	my $cachetime = 606024;
my ($result,$cached)=&is_cached_new('domdefaults',$domain);	unless ($ignore_cache) {
if (defined($cached)) {	my ($result,$cached)=&is_cached_new('domdefaults',$domain);
if (ref($result) eq 'HASH') {	if (defined($cached)) {
return %{$result};	if (ref($result) eq 'HASH') {
	return %{$result};
	}
}	}
}	}
my %domdefaults;	my %domdefaults;
Line 1985 sub get_domain_defaults {	Line 2020 sub get_domain_defaults {
$domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};	$domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
} else {	} else {
$domdefaults{'defaultquota'} = $domconfig{'quotas'};	$domdefaults{'defaultquota'} = $domconfig{'quotas'};
}	}
my @usertools = ('aboutme','blog','webdav','portfolio');	my @usertools = ('aboutme','blog','webdav','portfolio');
foreach my $item (@usertools) {	foreach my $item (@usertools) {
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {	if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
$domdefaults{$item} = $domconfig{'quotas'}{$item};	$domdefaults{$item} = $domconfig{'quotas'}{$item};
}	}
}	}
	if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') {
	$domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'};
	}
}	}
if (ref($domconfig{'requestcourses'}) eq 'HASH') {	if (ref($domconfig{'requestcourses'}) eq 'HASH') {
foreach my $item ('official','unofficial','community') {	foreach my $item ('official','unofficial','community','textbook') {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};	$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}	}
}	}
Line 2007 sub get_domain_defaults {	Line 2045 sub get_domain_defaults {
}	}
}	}
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
foreach my $item ('canuse_pdfforms') {	$domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
$domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
}
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
$domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};	$domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
$domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};	$domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
	$domdefaults{'textbookcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'textbook'};
	}
	if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
	$domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};
	$domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};
	$domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};
	$domdefaults{'textbookquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'textbook'};
}	}
}	}
if (ref($domconfig{'usersessions'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2816 sub can_edit_resource {	Line 2859 sub can_edit_resource {
$cfile =~ s{^http://}{};	$cfile =~ s{^http://}{};
$cfile = '/adm/wrapper/ext/'.$cfile;	$cfile = '/adm/wrapper/ext/'.$cfile;
}	}
	} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
	if ($env{'form.forceedit'}) {
	$forceview = 1;
	} else {
	$forceedit = 1;
	}
	$cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
}	}
}	}
if ($uploaded \|\| $incourse) {	if ($uploaded \|\| $incourse) {
Line 3453 sub extract_embedded_items {	Line 3503 sub extract_embedded_items {
}	}
}	}
}	}
	if (lc($tagname) eq 'iframe') {
	my $src = $attr->{'src'} ;
	if (($src ne '') && ($src !~ m{^(/\|https?://)})) {
	&add_filetype($allfiles,$src,'src');
	} elsif ($src =~ m{^/}) {
	if ($env{'request.course.id'}) {
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	my $url = &hreflocation('',$fullpath);
	if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
	my $relpath = $1;
	if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
	&add_filetype($allfiles,$1,'src');
	}
	}
	}
	}
	}
if ($t->[4] =~ m{/>$}) {	if ($t->[4] =~ m{/>$}) {
pop(@state);	pop(@state);
}	}
} elsif ($t->[0] eq 'E') {	} elsif ($t->[0] eq 'E') {
my ($tagname) = ($t->[1]);	my ($tagname) = ($t->[1]);
Line 4111 sub courseiddump {	Line 4179 sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,	$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,	$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;	$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
	$hasuniquecode)=@_;
my $as_hash = 1;	my $as_hash = 1;
my %returnhash;	my %returnhash;
if (!$domfilter) { $domfilter=''; }	if (!$domfilter) { $domfilter=''; }
Line 4134 sub courseiddump {	Line 4203 sub courseiddump {
&escape($catfilter), $showhidden, $caller,	&escape($catfilter), $showhidden, $caller,
&escape($cloner), &escape($cc_clone), $cloneonly,	&escape($cloner), &escape($cc_clone), $cloneonly,
&escape($createdbefore), &escape($createdafter),	&escape($createdbefore), &escape($createdafter),
&escape($creationcontext), $domcloner)));	&escape($creationcontext), $domcloner, $hasuniquecode)));
} else {	} else {
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'.	$rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
$sincefilter.':'.&escape($descfilter).':'.	$sincefilter.':'.&escape($descfilter).':'.
Line 4145 sub courseiddump {	Line 4214 sub courseiddump {
$showhidden.':'.$caller.':'.&escape($cloner).':'.	$showhidden.':'.$caller.':'.&escape($cloner).':'.
&escape($cc_clone).':'.$cloneonly.':'.	&escape($cc_clone).':'.$cloneonly.':'.
&escape($createdbefore).':'.&escape($createdafter).':'.	&escape($createdbefore).':'.&escape($createdafter).':'.
&escape($creationcontext).':'.$domcloner,	&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,
$tryserver);	$tryserver);
}	}

Line 4796 sub restore {	Line 4865 sub restore {
if ($stuname) { $home=&homeserver($stuname,$domain); }	if ($stuname) { $home=&homeserver($stuname,$domain); }

if (!$symb) {	if (!$symb) {
unless ($symb=escape(&symbread())) { return ''; }	return if ($namespace eq 'courserequests');
	unless ($symb=escape(&symbread())) { return ''; }
} else {	} else {
$symb=&escape(&symbclean($symb));	unless ($namespace eq 'courserequests') {
	$symb=&escape(&symbclean($symb));
	}
}	}
if (!$namespace) {	if (!$namespace) {
unless ($namespace=$env{'request.course.id'}) {	unless ($namespace=$env{'request.course.id'}) {
Line 5142 sub set_arearole {	Line 5214 sub set_arearole {
sub custom_roleprivs {	sub custom_roleprivs {
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;	my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
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 ($rdummy,$roledef)=	my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);	&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
Line 5263 sub set_userprivs {	Line 5335 sub set_userprivs {

sub role_status {	sub role_status {
my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;	my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
my @pwhere = ();
if (exists($env{$rolekey}) && $env{$rolekey} ne '') {	if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);	my ($one,$two) = split(m{\./},$rolekey,2);
	(undef,undef,$$role) = split(/\./,$one,3);
unless (!defined($$role) \|\| $$role eq '') {	unless (!defined($$role) \|\| $$role eq '') {
$$where=join('.',@pwhere);	$$where = '/'.$two;
$$trolecode=$$role.'.'.$$where;	$$trolecode=$$role.'.'.$$where;
($$tstart,$$tend)=split(/\./,$env{$rolekey});	($$tstart,$$tend)=split(/\./,$env{$rolekey});
$$tstatus='is';	$$tstatus='is';
Line 5473 sub unserialize {	Line 5545 sub unserialize {
return {} if $rep =~ /^error/;	return {} if $rep =~ /^error/;

my %returnhash=();	my %returnhash=();
foreach my $item (split /\&/, $rep) {	foreach my $item (split(/\&/,$rep)) {
my ($key, $value) = split(/=/, $item, 2);	my ($key, $value) = split(/=/, $item, 2);
$key = unescape($key) unless $escapedkeys;	$key = unescape($key) unless $escapedkeys;
next if $key =~ /^error: 2 /;	next if $key =~ /^error: 2 /;
$returnhash{$key} = Apache::lonnet::thaw_unescape($value);	$returnhash{$key} = &thaw_unescape($value);
}	}
#return %returnhash;	#return %returnhash;
return \%returnhash;	return \%returnhash;
Line 5495 sub dump {	Line 5567 sub dump {
if (grep { $_ eq $uhome } current_machine_ids()) {	if (grep { $_ eq $uhome } current_machine_ids()) {
# user is hosted on this machine	# user is hosted on this machine
$reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,	$reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
$uname, $namespace, $regexp, $range)), $loncaparevs{$uhome});	$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
return %{unserialize($reply, $escapedkeys)};	return %{unserialize($reply, $escapedkeys)};
}	}
if ($regexp) {	if ($regexp) {
Line 6138 sub usertools_access {	Line 6210 sub usertools_access {
official => 1,	official => 1,
unofficial => 1,	unofficial => 1,
community => 1,	community => 1,
	textbook => 1,
);	);
} elsif ($context eq 'requestauthor') {	} elsif ($context eq 'requestauthor') {
%tools = (	%tools = (
Line 6153 sub usertools_access {	Line 6226 sub usertools_access {
}	}
return if (!defined($tools{$tool}));	return if (!defined($tools{$tool}));

if ((!defined($udom)) \|\| (!defined($uname))) {	if (($udom eq '') \|\| ($uname eq '')) {
$udom = $env{'user.domain'};	$udom = $env{'user.domain'};
$uname = $env{'user.name'};	$uname = $env{'user.name'};
}	}
Line 6663 sub allowed {	Line 6736 sub allowed {
&& &is_portfolio_url($uri)) {	&& &is_portfolio_url($uri)) {
$thisallowed = &portfolio_access($uri);	$thisallowed = &portfolio_access($uri);
}	}

# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.
if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
return 'F';	return 'F';
Line 7244 sub definerole {	Line 7317 sub definerole {
# ---------------- Make a metadata query against the network of library servers	# ---------------- Make a metadata query against the network of library servers

sub metadata_query {	sub metadata_query {
my ($query,$custom,$customshow,$server_array)=@_;	my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;
my %rhash;	my %rhash;
my %libserv = &all_library();	my %libserv = &all_library();
my @server_list = (defined($server_array) ? @$server_array	my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );	: keys(%libserv) );
for my $server (@server_list) {	for my $server (@server_list) {
	my $domains = '';
	if (ref($domains_hash) eq 'HASH') {
	$domains = $domains_hash->{$server};
	}
unless ($custom or $customshow) {	unless ($custom or $customshow) {
my $reply=&reply("querysend:".&escape($query),$server);	my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
$rhash{$server}=$reply;	$rhash{$server}=$reply;
}	}
else {	else {
my $reply=&reply("querysend:".&escape($query).':'.	my $reply=&reply("querysend:".&escape($query).':'.
&escape($custom).':'.&escape($customshow),	&escape($custom).':'.&escape($customshow).':'.&escape($domains),
$server);	$server);
$rhash{$server}=$reply;	$rhash{$server}=$reply;
}	}
Line 7774 sub auto_validate_class_sec {	Line 7851 sub auto_validate_class_sec {
return $response;	return $response;
}	}

	sub auto_crsreq_update {
	my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
	$code,$inbound) = @_;
	my ($homeserver,%crsreqresponse);
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	unless (($homeserver eq 'no_host') \|\| ($homeserver eq '')) {
	my $info;
	if (ref($inbound) eq 'HASH') {
	$info = &freeze_escape($inbound);
	}
	my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
	':'.&escape($action).':'.&escape($ownername).':'.
	&escape($ownerdomain).':'.&escape($fullname).':'.
	&escape($title).':'.&escape($code).':'.$info,$homeserver);
	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
	my @items = split(/&/,$response);
	foreach my $item (@items) {
	my ($key,$value) = split('=',$item);
	$crsreqresponse{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	return \%crsreqresponse;
	}

# ------------------------------------------------------- Course Group routines	# ------------------------------------------------------- Course Group routines

sub get_coursegroups {	sub get_coursegroups {
Line 8455 sub modifystudent {	Line 8559 sub modifystudent {
$desiredhome,$email,$inststatus);	$desiredhome,$email,$inststatus);
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	# student's environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$locktype,	$gene,$usec,$end,$start,$type,$locktype,
Line 8766 sub store_userdata {	Line 8870 sub store_userdata {
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}	}
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
	unless ($namespace eq 'courserequests') {
	$datakey = &escape($datakey);
	}
$result = &reply("store:$udom:$uname:$namespace:$datakey:".	$result = &reply("store:$udom:$uname:$namespace:$datakey:".
$namevalue,$uhome);	$namevalue,$uhome);
}	}
Line 9588 sub resdata {	Line 9695 sub resdata {
return undef;	return undef;
}	}

	sub get_numsuppfiles {
	my ($cnum,$cdom,$ignorecache)=@_;
	my $hashid=$cnum.':'.$cdom;
	my ($suppcount,$cached);
	unless ($ignorecache) {
	($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
	}
	unless (defined($cached)) {
	my $chome=&homeserver($cnum,$cdom);
	unless ($chome eq 'no_host') {
	($suppcount,my $errors) = (0,0);
	my $suppmap = 'supplemental.sequence';
	($suppcount,$errors) =
	&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
	}
	&do_cache_new('suppcount',$hashid,$suppcount,600);
	}
	return $suppcount;
	}

#	#
# EXT resource caching routines	# EXT resource caching routines
#	#
Line 9616 sub EXT_cache_set {	Line 9743 sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable
sub EXT {	sub EXT {

my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;	my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;
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;
Line 9731 sub EXT {	Line 9858 sub EXT {
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
}	}

if ($space eq 'title') {	if ($qualifier eq '') {
if (!$symbparm) { $symbparm = $env{'request.filename'}; }	if ($space eq 'title') {
return &gettitle($symbparm);	if (!$symbparm) { $symbparm = $env{'request.filename'}; }
}	return &gettitle($symbparm);
	}

if ($space eq 'map') {	if ($space eq 'map') {
my ($map) = &decode_symb($symbparm);	my ($map) = &decode_symb($symbparm);
return &symbread($map);	return &symbread($map);
}	}
if ($space eq 'filename') {	if ($space eq 'maptitle') {
if ($symbparm) {	my ($map) = &decode_symb($symbparm);
return &clutter((&decode_symb($symbparm))[2]);	return &gettitle($map);
	}
	if ($space eq 'filename') {
	if ($symbparm) {
	return &clutter((&decode_symb($symbparm))[2]);
	}
	return &hreflocation('',$env{'request.filename'});
}	}
return &hreflocation('',$env{'request.filename'});
}	if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {
	if ($space eq 'visibleparts') {
	my $navmap = Apache::lonnavmaps::navmap->new();
	my $item;
	if (ref($navmap)) {
	my $res = $navmap->getBySymb($symbparm);
	my $parts = $res->parts();
	if (ref($parts) eq 'ARRAY') {
	$item = join(',',@{$parts});
	}
	undef($navmap);
	}
	return $item;
	}
	}
	}

my ($section, $group, @groups);	my ($section, $group, @groups);
my ($courselevelm,$courselevel);	my ($courselevelm,$courselevel);
if ($symbparm && defined($courseid) &&	if (($courseid eq '') && ($cid)) {
$courseid eq $env{'request.course.id'}) {	$courseid = $cid;
	}
	if (($symbparm && $courseid) &&
	(($courseid eq $env{'request.course.id'}) \|\| ($courseid eq $cid))) {

#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;	#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;

Line 11610 sub parse_dns_checksums_tab {	Line 11762 sub parse_dns_checksums_tab {
my (%chksum,%revnum);	my (%chksum,%revnum);
if (ref($lines) eq 'ARRAY') {	if (ref($lines) eq 'ARRAY') {
chomp(@{$lines});	chomp(@{$lines});
my $versions = shift(@{$lines});	my $version = shift(@{$lines});
my %supported;	if ($version eq $release) {
if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) {
my $releaseslist = $1;
if ($releaseslist =~ /,/) {
map { $supported{$_} = 1; } split(/,/,$releaseslist);
} elsif ($releaseslist) {
$supported{$releaseslist} = 1;
}
}
if ($supported{$release}) {
my $matchthis = 0;
foreach my $line (@{$lines}) {	foreach my $line (@{$lines}) {
if ($line =~ /^(\d[\w\.]+)$/) {	my ($file,$version,$shasum) = split(/,/,$line);
if ($matchthis) {	$chksum{$file} = $shasum;
last;	$revnum{$file} = $version;
} elsif ($1 eq $release) {
$matchthis = 1;
}
} elsif ($matchthis) {
my ($file,$version,$shasum) = split(/,/,$line);
$chksum{$file} = $shasum;
$revnum{$file} = $version;
}
}	}
if (ref($hashref) eq 'HASH') {	if (ref($hashref) eq 'HASH') {
%{$hashref} = (	%{$hashref} = (
Line 11647 sub parse_dns_checksums_tab {	Line 11781 sub parse_dns_checksums_tab {
}	}

sub fetch_dns_checksums {	sub fetch_dns_checksums {
my %checksums;	my %checksums;
&get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,	my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
	my $loncaparev = &get_server_loncaparev($machine_dom);
	my ($release,$timestamp) = split(/\-/,$loncaparev);
	&get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
\%checksums);	\%checksums);
return \%checksums;	return \%checksums;
}	}
Line 12026 sub fetch_dns_checksums {	Line 12163 sub fetch_dns_checksums {
}	}

sub all_loncaparevs {	sub all_loncaparevs {
return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);	return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
	}

	# ---------------------------------------------------------- Read loncaparev table
	{
	sub load_loncaparevs {
	if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
	if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
	while (my $configline=<$config>) {
	chomp($configline);
	my ($hostid,$loncaparev)=split(/:/,$configline);
	$loncaparevs{$hostid}=$loncaparev;
	}
	close($config);
	}
	}
	}
	}

	# ---------------------------------------------------------- Read serverhostID table
	{
	sub load_serverhomeIDs {
	if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
	if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
	while (my $configline=<$config>) {
	chomp($configline);
	my ($name,$id)=split(/:/,$configline);
	$serverhomeIDs{$name}=$id;
	}
	close($config);
	}
	}
	}
}	}


BEGIN {	BEGIN {

# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
Line 12105 BEGIN {	Line 12275 BEGIN {
}	}

# ---------------------------------------------------------- Read loncaparev table	# ---------------------------------------------------------- Read loncaparev table
{
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {	&load_loncaparevs();
if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
while (my $configline=<$config>) {
chomp($configline);
my ($hostid,$loncaparev)=split(/:/,$configline);
$loncaparevs{$hostid}=$loncaparev;
}
close($config);
}
}
}

# ---------------------------------------------------------- Read serverhostID table	# ---------------------------------------------------------- Read serverhostID table
{
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
while (my $configline=<$config>) {
chomp($configline);
my ($name,$id)=split(/:/,$configline);
$serverhomeIDs{$name}=$id;
}
close($config);
}
}
}

	&load_serverhomeIDs();

	# ---------------------------------------------------------- Read releaseslist XML
{	{
my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';	my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';
if (-e $file) {	if (-e $file) {
Line 12190 $readit=1;	Line 12341 $readit=1;
if ($test != 0) { $_64bit=1; } else { $_64bit=0; }	if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
&logthis(" Detected 64bit platform ($_64bit)");	&logthis(" Detected 64bit platform ($_64bit)");
}	}

{
eval {
($apache) =
(Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)});
};
if ($@) {
$apache = 1.3;
}
}

}	}
}	}

Line 12341 were new keys. I.E. 1:foo will become 1:	Line 12481 were new keys. I.E. 1:foo will become 1:

Calling convention:	Calling convention:

my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);	my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
&Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);	&Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);

For more detailed information, see lonnet specific documentation.	For more detailed information, see lonnet specific documentation.

Line 12609 or when Autoupdate.pl is run by cron in	Line 12749 or when Autoupdate.pl is run by cron in
modifystudent	modifystudent

modify a student's enrollment and identification information.	modify a student's enrollment and identification information.
The course id is resolved based on the current users environment.	The course id is resolved based on the current user's environment.
This means the envoking user must be a course coordinator or otherwise	This means the invoking user must be a course coordinator or otherwise
associated with a course.	associated with a course.

This call is essentially a wrapper for lonnet::modifyuser and	This call is essentially a wrapper for lonnet::modifyuser and
Line 12670 Inputs:	Line 12810 Inputs:

modify_student_enrollment	modify_student_enrollment

Change a students enrollment status in a class. The environment variable	Change a student's enrollment status in a class. The environment variable
'role.request.course' must be defined for this function to proceed.	'role.request.course' must be defined for this function to proceed.

Inputs:	Inputs:

=over 4	=over 4

=item $udom, students domain	=item $udom, student's domain

=item $uname, students name	=item $uname, student's name

=item $uid, students user id	=item $uid, student's user id

=item $first, students first name	=item $first, student's first name

=item $middle	=item $middle

Line 12765 If defined, the supplied username is use	Line 12905 If defined, the supplied username is use
resdata($name,$domain,$type,@which) : request for current parameter	resdata($name,$domain,$type,@which) : request for current parameter
setting for a specific $type, where $type is either 'course' or 'user',	setting for a specific $type, where $type is either 'course' or 'user',
@what should be a list of parameters to ask about. This routine caches	@what should be a list of parameters to ask about. This routine caches
answers for 5 minutes.	answers for 10 minutes.

=item *	=item *

Line 12774 data base, returning a hash that is keye	Line 12914 data base, returning a hash that is keye
values that are the resource value. I believe that the timestamps and	values that are the resource value. I believe that the timestamps and
versions are also returned.	versions are also returned.

	get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
	supplemental content area. This routine caches the number of files for
	10 minutes.

=back	=back

=head2 Course Modification	=head2 Course Modification
Line 12833 resource. Expects the local filesystem p	Line 12977 resource. Expects the local filesystem p

=item *	=item *

EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of	EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates
a vairety of different possible values, $varname should be a request	and returns the value of a variety of different possible values,
string, and the other parameters can be used to specify who and what	$varname should be a request string, and the other parameters can be
one is asking about.	used to specify who and what one is asking about. Ordinarily, $cid
	does not need to be specified, as it is retrived from
	$env{'request.course.id'}, but &Apache::lonnet::EXT() is called
	within lonuserstate::loadmap() when initializing a course, before
	$env{'request.course.id'} has been set, so it needs to be provided
	in that one case.

Possible values for $varname are environment.lastname (or other item	Possible values for $varname are environment.lastname (or other item
from the envirnment hash), user.name (or someother aspect about the	from the envirnment hash), user.name (or someother aspect about the
Line 13114 server ($udom and $uhome are optional)	Line 13263 server ($udom and $uhome are optional)

=item *	=item *

get_domain_defaults($target_domain) : returns hash with defaults for	get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults
authentication and language in the domain. Keys are: auth_def, auth_arg_def,	for: authentication, language, quotas, timezone, date locale, and portal URL in
lang_def; corresponsing values are authentication type (internal, krb4, krb5,	the target domain.
or localauth), initial password or a kerberos realm, language (e.g., en-us).
Values are retrieved from cache (if current), or from domain's configuration.db	May also include additional key => value pairs for the following groups:
(if available), or lastly from values in lonTabs/dns_domain,tab,
or lonTabs/domain.tab.	=over

	=item
	disk quotas (MB allocated by default to portfolios and authoring spaces).

	=over

	=item defaultquota, authorquota

	=back

	=item
	tools (availability of aboutme page, blog, webDAV access for authoring spaces,
	portfolio for users).

	=over

	=item
	aboutme, blog, webdav, portfolio

	=back

	=item
	requestcourses: ability to request courses, and how requests are processed.

	=over

	=item
	official, unofficial, community, textbook

	=back

	=item
	inststatus: types of institutional affiliation, and order in which they are displayed.

	=over

	=item
	inststatustypes, inststatusorder

	=back

	=item
	coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
	for course's uploaded content.

	=over

	=item
	canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
	communityquota, textbookquota

	=back

	=item
	usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
	on your servers.

	=over

	=item
	remotesessions, hostedsessions

	=back

	=back

	In cases where a domain coordinator has never used the "Set Domain Configuration"
	utility to create a configuration.db file on a domain's primary library server
	only the following domain defaults: auth_def, auth_arg_def, lang_def
	-- corresponding values are authentication type (internal, krb4, krb5,
	or localauth), initial password or a kerberos realm, language (e.g., en-us) --
	will be available. Values are retrieved from cache (if current), unless the
	optional $ignore_cache arg is true, or from domain's configuration.db (if available),
	or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.

	Typical usage:

%domdefaults = &get_auth_defaults($target_domain);	%domdefaults = &get_domain_defaults($target_domain);

=back	=back

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.1223
changed lines
	Added in v.1.1252