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.1056.4.33.2.1 and 1.1115

version 1.1056.4.33.2.1, 2012/02/01 18:27:09	version 1.1115, 2011/06/12 14:18:12
Line 76 use HTTP::Date;	Line 76 use HTTP::Date;
use Image::Magick;	use Image::Magick;

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

my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,	my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,	%userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 288 sub get_server_homeID {	Line 287 sub get_server_homeID {
}	}
my $cachetime = 12*3600;	my $cachetime = 12*3600;
my $serverhomeID;	my $serverhomeID;
if ($caller eq 'loncron') {	if ($caller eq 'loncron') {
my @machine_ids = &machine_ids($hostname);	my @machine_ids = &machine_ids($hostname);
foreach my $id (@machine_ids) {	foreach my $id (@machine_ids) {
my $response = &reply('serverhomeID',$id);	my $response = &reply('serverhomeID',$id);
Line 636 sub appenv {	Line 635 sub appenv {
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment

sub delenv {	sub delenv {
my ($delthis,$regexp) = @_;	my ($delthis,$regexp,$roles) = @_;
if (($delthis=~/user\.role/) \|\| ($delthis=~/user\.priv/)) {	if (($delthis=~/^user\.role/) \|\| ($delthis=~/^user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".	my $refused = 1;
"Attempt to delete from environment ".$delthis);	if (ref($roles) eq 'ARRAY') {
return 'error';	my ($type,$role) = ($delthis =~ /^user\.(role\|priv)\.([^.]+)\./);
	if (grep(/^\Q$role\E$/,@{$roles})) {
	$refused = 0;
	}
	}
	if ($refused) {
	&logthis("<font color=\"blue\">WARNING: ".
	"Attempt to delete from environment ".$delthis);
	return 'error';
	}
}	}
my $opened = open(my $env_file,'+<',$env{'user.environment'});	my $opened = open(my $env_file,'+<',$env{'user.environment'});
if ($opened	if ($opened
Line 749 sub userload {	Line 757 sub userload {
return $userloadpercent;	return $userloadpercent;
}	}

# ------------------------------------------ Fight off request when overloaded

sub overloaderror {
my ($r,$checkserver)=@_;
unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
my $loadavg;
if ($checkserver eq $perlvar{'lonHostID'}) {
open(my $loadfile,'/proc/loadavg');
$loadavg=<$loadfile>;
$loadavg =~ s/\s.*//g;
$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
close($loadfile);
} else {
$loadavg=&reply('load',$checkserver);
}
my $overload=$loadavg-100;
if ($overload>0) {
$r->err_headers_out->{'Retry-After'}=$overload;
$r->log_error('Overload of '.$overload.' on '.$checkserver);
return 413;
}
return '';
}

# ------------------------------ Find server with least workload from spare.tab	# ------------------------------ Find server with least workload from spare.tab

sub spareserver {	sub spareserver {
Line 790 sub spareserver {	Line 774 sub spareserver {
}	}
foreach my $try_server (@{ $spareid{'primary'} }) {	foreach my $try_server (@{ $spareid{'primary'} }) {
if ($uint_dom) {	if ($uint_dom) {
next unless (&spare_can_host($udom,$uint_dom,$remotesessions,	next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
$try_server));	$try_server));
}	}
($spare_server, $lowest_load) =	($spare_server, $lowest_load) =
&compare_server_load($try_server, $spare_server, $lowest_load);	&compare_server_load($try_server, $spare_server, $lowest_load);
Line 832 sub compare_server_load {	Line 816 sub compare_server_load {
my $userloadans = &reply('userload',$try_server);	my $userloadans = &reply('userload',$try_server);

if ($loadans !~ /\d/ && $userloadans !~ /\d/) {	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
return ($spare_server, $lowest_load); #didn't get a number from the server	return ($spare_server, $lowest_load); #didn't get a number from the server
}	}

my $load;	my $load;
Line 882 sub choose_server {	Line 866 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,$isredirect);	my ($login_host,$hostname);
foreach my $lonhost (keys(%servers)) {	foreach my $lonhost (keys(%servers)) {
my $loginvia;	my $loginvia;
if ($checkloginvia) {	if ($checkloginvia) {
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};	$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
if ($loginvia) {	}
my ($server,$path) = split(/:/,$loginvia);	if ($loginvia eq '') {
($login_host, $lowest_load) =
&compare_server_load($lonhost, $login_host, $lowest_load);
if ($login_host eq $server) {
$portal_path = $path;
$isredirect = 1;
}
} else {
($login_host, $lowest_load) =
&compare_server_load($lonhost, $login_host, $lowest_load);
if ($login_host eq $lonhost) {
$portal_path = '';
$isredirect = '';
}
}
} 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 ne '') {	if ($login_host ne '') {
$hostname = &hostname($login_host);	$hostname = $servers{$login_host};
}	}
return ($login_host,$hostname,$portal_path,$isredirect);	return ($login_host,$hostname);
}	}

# --------------------------------------------- Try to change a user's password	# --------------------------------------------- Try to change a user's password
Line 1052 sub can_host_session {	Line 1021 sub can_host_session {
}	}
if ($canhost) {	if ($canhost) {
if (ref($hostedsessions) eq 'HASH') {	if (ref($hostedsessions) eq 'HASH') {
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {	if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
if (($uint_dom ne '') &&	if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
$canhost = 0;	$canhost = 0;
} else {	} else {
$canhost = 1;	$canhost = 1;
}	}
}	}
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {	if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
if (($uint_dom ne '') &&	if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {
$canhost = 1;	$canhost = 1;
} else {	} else {
$canhost = 0;	$canhost = 0;
Line 1578 sub get_domain_defaults {	Line 1543 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 2038 sub getversion {	Line 2002 sub getversion {

sub currentversion {	sub currentversion {
my $fname=shift;	my $fname=shift;
my ($result,$cached)=&is_cached_new('resversion',$fname);
if (defined($cached)) { return $result; }
my $author=$fname;	my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);	my ($udom,$uname)=split(/\//,$author);
my $home=homeserver($uname,$udom);	my $home=&homeserver($uname,$udom);
if ($home eq 'no_host') {	if ($home eq 'no_host') {
return -1;	return -1;
}	}
my $answer=reply("currentversion:$fname",$home);	my $answer=&reply("currentversion:$fname",$home);
if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {	if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {
return -1;	return -1;
}	}
return &do_cache_new('resversion',$fname,$answer,600);	return $answer;
	}

	#
	# Return special version number of resource if set by override, empty otherwise
	#
	sub usedversion {
	my $fname=shift;
	unless ($fname) { $fname=$env{'request.uri'}; }
	my ($urlversion)=($fname=~/\.(\d+)\.\w+$/);
	if ($urlversion) { return $urlversion; }
	return '';
}	}

# ----------------------------- Subscribe to a resource, return URL if possible	# ----------------------------- Subscribe to a resource, return URL if possible
Line 2313 sub process_coursefile {	Line 2286 sub process_coursefile {
}	}
if (ref($mimetype)) {	if (ref($mimetype)) {
$$mimetype = $type;	$$mimetype = $type;
}	}
}	}
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
$home);	$home);
Line 2431 sub resizeImage {	Line 2404 sub resizeImage {
# input: $formname - the contents of the file are in $env{"form.$formname"}	# input: $formname - the contents of the file are in $env{"form.$formname"}
# the desired filename is in $env{"form.$formname.filename"}	# the desired filename is in $env{"form.$formname.filename"}
# $context - possible values: coursedoc, existingfile, overwrite,	# $context - possible values: coursedoc, existingfile, overwrite,
# canceloverwrite, or ''.	# canceloverwrite, or ''.
# if 'coursedoc': upload to the current course	# if 'coursedoc': upload to the current course
# if 'existingfile': write file to tmp/overwrites directory	# if 'existingfile': write file to tmp/overwrites directory
# if 'canceloverwrite': delete file written to tmp/overwrites directory	# if 'canceloverwrite': delete file written to tmp/overwrites directory
# $context is passed as argument to &finishuserfileupload	# $context is passed as argument to &finishuserfileupload
# $subdir - directory in userfile to store the file into	# $subdir - directory in userfile to store the file into
# $parser - instruction to parse file for objects ($parser = parse)	# $parser - instruction to parse file for objects ($parser = parse)
# $allfiles - reference to hash for embedded objects	# $allfiles - reference to hash for embedded objects
Line 2591 sub finishuserfileupload {	Line 2564 sub finishuserfileupload {
my $target = $filepath.'/'.$file;	my $target = $filepath.'/'.$file;
if (-e $source) {	if (-e $source) {
my @info = stat($source);	my @info = stat($source);
if ($info[9] eq $env{'form.timestamp'}) {	if ($info[9] eq $env{'form.timestamp'}) {
unless (&File::Copy::move($source,$target)) {	unless (&File::Copy::move($source,$target)) {
&logthis('Failed to overwrite '.$filepath.'/'.$file);	&logthis('Failed to overwrite '.$filepath.'/'.$file);
return "Moving from $source failed";	return "Moving from $source failed";
Line 2602 sub finishuserfileupload {	Line 2575 sub finishuserfileupload {
} else {	} else {
return "Temporary file: $source missing";	return "Temporary file: $source missing";
}	}
} elsif (!print FH ($env{'form.'.$formname})) {	} elsif (!print FH ($env{'form.'.$formname})) {
&logthis('Failed to write to '.$filepath.'/'.$file);	&logthis('Failed to write to '.$filepath.'/'.$file);
print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");	print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
return '/adm/notfound.html';	return '/adm/notfound.html';
Line 3163 sub get_my_roles {	Line 3136 sub get_my_roles {
unless (defined($uname)) { $uname=$env{'user.name'}; }	unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }	unless (defined($udom)) { $udom=$env{'user.domain'}; }
my (%dumphash,%nothide);	my (%dumphash,%nothide);
if ($context eq 'userroles') {	if ($context eq 'userroles') {
my $extra = &freeze_escape({'skipcheck' => 1});	my $extra = &freeze_escape({'skipcheck' => 1});
%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);	%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
} else {	} else {
Line 3225 sub get_my_roles {	Line 3198 sub get_my_roles {
if (!grep(/^cr$/,@{$roles})) {	if (!grep(/^cr$/,@{$roles})) {
next;	next;
}	}
	} elsif ($role =~ /^gr\//) {
	if (!grep(/^gr$/,@{$roles})) {
	next;
	}
} else {	} else {
next;	next;
}	}
Line 3493 sub get_domain_roles {	Line 3470 sub get_domain_roles {
return %personnel;	return %personnel;
}	}

# ----------------------------------------------------------- Check out an item	# ----------------------------------------------------------- Interval timing

sub get_first_access {	sub get_first_access {
my ($type,$argsymb)=@_;	my ($type,$argsymb)=@_;
Line 3529 sub set_first_access {	Line 3506 sub set_first_access {
return 'already_set';	return 'already_set';
}	}

sub checkout {
my ($symb,$tuname,$tudom,$tcrsid)=@_;
my $now=time;
my $lonhost=$perlvar{'lonHostID'};
my $infostr=&escape(
'CHECKOUTTOKEN&'.
$tuname.'&'.
$tudom.'&'.
$tcrsid.'&'.
$symb.'&'.
$now.'&'.$ENV{'REMOTE_ADDR'});
my $token=&reply('tmpput:'.$infostr,$lonhost);
if ($token=~/^error\:/) {
&logthis("<font color=\"blue\">WARNING: ".
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
return '';
}

$token=~s/^(\d+)\_.\_(\d+)$/$1\$2\*$lonhost/;
$token=~tr/a-z/A-Z/;

my %infohash=('resource.0.outtoken' => $token,
'resource.0.checkouttime' => $now,
'resource.0.outremote' => $ENV{'REMOTE_ADDR'});

unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';
} else {
&logthis("<font color=\"blue\">WARNING: ".
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}

if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
&escape('Checkout '.$infostr.' - '.
$token)) ne 'ok') {
return '';
} else {
&logthis("<font color=\"blue\">WARNING: ".
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}
return $token;
}

# ------------------------------------------------------------ Check in an item

sub checkin {
my $token=shift;
my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));

unless (($tuname) && ($tudom)) {
&logthis('Check in '.$token.' ('.$dtoken.') failed');
return '';
}

unless (&allowed('mgr',$tcrsid)) {
&logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
$env{'user.name'}.' - '.$env{'user.domain'});
return '';
}

my %infohash=('resource.0.intoken' => $token,
'resource.0.checkintime' => $now,
'resource.0.inremote' => $ENV{'REMOTE_ADDR'});

unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';
}

if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
&escape('Checkin - '.$token)) ne 'ok') {
return '';
}

return ($symb,$tuname,$tudom,$tcrsid);
}

# --------------------------------------------- Set Expire Date for Spreadsheet	# --------------------------------------------- Set Expire Date for Spreadsheet

sub expirespread {	sub expirespread {
Line 3718 sub hashref2str {	Line 3610 sub hashref2str {
$result.='=';	$result.='=';
#print("Got a ref of ".(ref($key))." skipping.");	#print("Got a ref of ".(ref($key))." skipping.");
} else {	} else {
if (defined($key)) {$result.=&escape($key).'=';} else { last; }	if ($key) {$result.=&escape($key).'=';} else { last; }
}	}

if(ref($hashref->{$key}) eq 'ARRAY') {	if(ref($hashref->{$key}) eq 'ARRAY') {
Line 4237 sub rolesinit {	Line 4129 sub rolesinit {
}	}
my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();
my $group_privs;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach my $entry (split(/&/,$rolesdump)) {	foreach my $entry (split(/&/,$rolesdump)) {
Line 4254 sub rolesinit {	Line 4145 sub rolesinit {
}	}
} elsif ($role =~ m\|^gr/\|) {	} elsif ($role =~ m\|^gr/\|) {
($trole,$tend,$tstart) = split(/_/,$role);	($trole,$tend,$tstart) = split(/_/,$role);
	next if ($tstart eq '-1');
($trole,$group_privs) = split(/\//,$trole);	($trole,$group_privs) = split(/\//,$trole);
$group_privs = &unescape($group_privs);	$group_privs = &unescape($group_privs);
} else {	} else {
Line 4358 sub set_userprivs {	Line 4250 sub set_userprivs {
my $adv=0;	my $adv=0;
my %grouproles = ();	my %grouproles = ();
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
my @groupkeys;	my @groupkeys;
foreach my $role (keys(%{$allroles})) {	foreach my $role (keys(%{$allroles})) {
push(@groupkeys,$role);	push(@groupkeys,$role);
}	}
Line 4406 sub set_userprivs {	Line 4298 sub set_userprivs {
}	}
}	}
my $thesestr='';	my $thesestr='';
foreach my $priv (keys(%thesepriv)) {	foreach my $priv (sort(keys(%thesepriv))) {
$thesestr.=':'.$priv.'&'.$thesepriv{$priv};	$thesestr.=':'.$priv.'&'.$thesepriv{$priv};
}	}
$userroles->{'user.priv.'.$role} = $thesestr;	$userroles->{'user.priv.'.$role} = $thesestr;
Line 4415 sub set_userprivs {	Line 4307 sub set_userprivs {
}	}

sub role_status {	sub role_status {
my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;	my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
my @pwhere = ();	my @pwhere = ();
if (exists($env{$rolekey}) && $env{$rolekey} ne '') {	if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);	(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
Line 4424 sub role_status {	Line 4316 sub role_status {
$$trolecode=$$role.'.'.$$where;	$$trolecode=$$role.'.'.$$where;
($$tstart,$$tend)=split(/\./,$env{$rolekey});	($$tstart,$$tend)=split(/\./,$env{$rolekey});
$$tstatus='is';	$$tstatus='is';
if ($$tstart && $$tstart>$then) {	if ($$tstart && $$tstart>$update) {
$$tstatus='future';	$$tstatus='future';
if ($$tstart<$now) {	if ($$tstart<$now) {
if ($$tstart && $$tstart>$refresh) {	if ($$tstart && $$tstart>$refresh) {
Line 4434 sub role_status {	Line 4326 sub role_status {
my %userroles = (	my %userroles = (
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend	'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
);	);
@rolecodes = ('cm');	@rolecodes = ('cm');
my $spec=$$role.'.'.$$where;	my $spec=$$role.'.'.$$where;
my ($tdummy,$tdomain,$trest)=split(/\//,$$where);	my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
if ($$role =~ /^cr\//) {	if ($$role =~ /^cr\//) {
Line 4449 sub role_status {	Line 4341 sub role_status {
$group_privs = &unescape($group_privs);	$group_privs = &unescape($group_privs);
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);	&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);	my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
if (keys(%course_roles) > 0) {	&get_groups_roles($tdomain,$trest,
my ($tnum) = ($trest =~ /^($match_courseid)/);	\%course_roles,\@rolecodes,
if ($tdomain ne '' && $tnum ne '') {	\%groups_roles);
foreach my $key (keys(%course_roles)) {
if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
my $crsrole = $1;
my $crssec = $2;
if ($crsrole =~ /^cr/) {
unless (grep(/^cr$/,@rolecodes)) {
push(@rolecodes,'cr');
}
} else {
unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {
push(@rolecodes,$crsrole);
}
}
my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;
if ($crssec ne '') {
$rolekey .= '/'.$crssec;
}
$rolekey .= './';
$groups_roles{$rolekey} = \@rolecodes;
}
}
}
}
} else {	} else {
push(@rolecodes,$$role);	push(@rolecodes,$$role);
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);	&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
Line 4488 sub role_status {	Line 4357 sub role_status {
}	}
}	}
if ($$tend) {	if ($$tend) {
if ($$tend<$then) {	if ($$tend<$update) {
$$tstatus='expired';	$$tstatus='expired';
} elsif ($$tend<$now) {	} elsif ($$tend<$now) {
$$tstatus='will_not';	$$tstatus='will_not';
Line 4498 sub role_status {	Line 4367 sub role_status {
}	}
}	}

	sub get_groups_roles {
	my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_;
	return unless((ref($cdom_courseroles) eq 'HASH') &&
	(ref($rolecodes) eq 'ARRAY') &&
	(ref($groups_roles) eq 'HASH'));
	if (keys(%{$cdom_courseroles}) > 0) {
	my ($cnum) = ($rest =~ /^($match_courseid)/);
	if ($cdom ne '' && $cnum ne '') {
	foreach my $key (keys(%{$cdom_courseroles})) {
	if ($key =~ /^\Q$cnum\E:\Q$cdom\E:([^:]+):?([^:]*)/) {
	my $crsrole = $1;
	my $crssec = $2;
	if ($crsrole =~ /^cr/) {
	unless (grep(/^cr$/,@{$rolecodes})) {
	push(@{$rolecodes},'cr');
	}
	} else {
	unless(grep(/^\Q$crsrole\E$/,@{$rolecodes})) {
	push(@{$rolecodes},$crsrole);
	}
	}
	my $rolekey = "$crsrole./$cdom/$cnum";
	if ($crssec ne '') {
	$rolekey .= "/$crssec";
	}
	$rolekey .= './';
	$groups_roles->{$rolekey} = $rolecodes;
	}
	}
	}
	}
	return;
	}

	sub delete_env_groupprivs {
	my ($where,$courseroles,$possroles) = @_;
	return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY'));
	my ($dummy,$udom,$uname,$group) = split(/\//,$where);
	unless (ref($courseroles->{$udom}) eq 'HASH') {
	%{$courseroles->{$udom}} =
	&get_my_roles('','','userroles',['active'],
	$possroles,[$udom],1);
	}
	if (ref($courseroles->{$udom}) eq 'HASH') {
	foreach my $item (keys(%{$courseroles->{$udom}})) {
	my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item);
	my $area = '/'.$cdom.'/'.$cnum;
	my $privkey = "user.priv.$crsrole.$area";
	if ($crssec ne '') {
	$privkey .= '/'.$crssec;
	}
	$privkey .= ".$area/$group";
	&Apache::lonnet::delenv($privkey,undef,[$crsrole]);
	}
	}
	return;
	}

sub check_adhoc_privs {	sub check_adhoc_privs {
my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_;	my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;	my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
if ($env{$cckey}) {	if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);	my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
&role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);	&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {	unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);	&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
}	}
Line 4594 sub dump {	Line 4521 sub dump {
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);	my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
foreach my $item (@pairs) {	if (!($rep =~ /^error/ )) {
my ($key,$value)=split(/=/,$item,2);	foreach my $item (@pairs) {
$key = &unescape($key);	my ($key,$value)=split(/=/,$item,2);
next if ($key =~ /^error: 2 /);	$key = &unescape($key);
$returnhash{$key}=&thaw_unescape($value);	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
}	}
return %returnhash;	return %returnhash;
}	}


# --------------------------------------------------------- dumpstore interface	# --------------------------------------------------------- dumpstore interface

sub dumpstore {	sub dumpstore {
Line 4885 sub tmpget {	Line 4815 sub tmpget {
return %returnhash;	return %returnhash;
}	}

# ------------------------------------------------------------ tmpget interface	# ------------------------------------------------------------ tmpdel interface
sub tmpdel {	sub tmpdel {
my ($token,$server)=@_;	my ($token,$server)=@_;
if (!defined($server)) { $server = $perlvar{'lonHostID'}; }	if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
Line 5136 sub is_portfolio_file {	Line 5066 sub is_portfolio_file {
}	}

sub usertools_access {	sub usertools_access {
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_;	my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
my ($access,%tools);	my ($access,%tools);
if ($context eq '') {	if ($context eq '') {
$context = 'tools';	$context = 'tools';
Line 5283 sub is_advanced_user {	Line 5213 sub is_advanced_user {
my ($udom,$uname) = @_;	my ($udom,$uname) = @_;
if ($udom ne '' && $uname ne '') {	if ($udom ne '' && $uname ne '') {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
return $env{'user.adv'};	return $env{'user.adv'};
}	}
}	}
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);	my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
Line 5801 sub allowed {	Line 5731 sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};	my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}	if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {	=~/\Q$rolecode\E/) {
if (($priv ne 'pch') && ($priv ne 'plc')) {	if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$env{'request.course.id'});	$env{'request.course.id'});
Line 5811 sub allowed {	Line 5741 sub allowed {

if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}	if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {	=~/\Q$unamedom\E/) {
if (($priv ne 'pch') && ($priv ne 'plc')) {	if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.	'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$env{'request.course.id'});	$env{'request.course.id'});
Line 5825 sub allowed {	Line 5755 sub allowed {
if ($thisallowed=~/R/) {	if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$env{'request.role'}))[0];	my $rolecode=(split(/\./,$env{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {	if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
if (($priv ne 'pch') && ($priv ne 'plc')) {	if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
}	}
Line 6752 sub assignrole {	Line 6682 sub assignrole {
return 'refused';	return 'refused';
}	}
}	}
} elsif ($role eq 'au') {
if ($url ne '/'.$udom.'/') {
&logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}.
' to assign author role for '.$uname.':'.$udom.
' in domain: '.$url.' refused (wrong domain).');
return 'refused';
}
}	}
$mrole=$role;	$mrole=$role;
}	}
Line 6933 sub modifyuser {	Line 6856 sub modifyuser {
}	}
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.	$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
(defined($desiredhome) ? ' desiredhome = '.$desiredhome :	(defined($desiredhome) ? ' desiredhome = '.$desiredhome :
' desiredhome not specified').	' desiredhome not specified').
' by '.$env{'user.name'}.' at '.$env{'user.domain'}.	' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
Line 7079 sub modifyuser {	Line 7002 sub modifyuser {
return 'ok';	return 'ok';
}	}
my $reply = &put('environment', \%names, $udom,$uname);	my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') {	if ($reply ne 'ok') {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {	if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
Line 7461 sub is_locked {	Line 7384 sub is_locked {
my ($file_name, $domain, $user, $which) = @_;	my ($file_name, $domain, $user, $which) = @_;
my @check;	my @check;
my $is_locked;	my $is_locked;
push(@check,$file_name);	push (@check,$file_name);
my %locked = &get('file_permissions',\@check,	my %locked = &get('file_permissions',\@check,
$env{'user.domain'},$env{'user.name'});	$env{'user.domain'},$env{'user.name'});
my ($tmp)=keys(%locked);	my ($tmp)=keys(%locked);
Line 8625 sub add_prefix_and_part {	Line 8548 sub add_prefix_and_part {
# ---------------------------------------------------------------- Get metadata	# ---------------------------------------------------------------- Get metadata

my %metaentry;	my %metaentry;
	my %importedpartids;
sub metadata {	sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);	$uri=&declutter($uri);
Line 8651 sub metadata {	Line 8575 sub metadata {
if (defined($cached)) { return $result->{':'.$what}; }	if (defined($cached)) { return $result->{':'.$what}; }
}	}
{	{
	# Imported parts would go here
	my %importedids=();
	my @origfileimportpartids=();
	my $importedparts=0;
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
Line 8735 sub metadata {	Line 8663 sub metadata {
# This is not a package - some other kind of start tag	# This is not a package - some other kind of start tag
#	#
my $entry=$token->[1];	my $entry=$token->[1];
my $unikey;	my $unikey='';
if ($entry eq 'import') {
$unikey='';
} else {
$unikey=$entry;
}
$unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});

if (defined($token->[2]->{'id'})) {
$unikey.='_'.$token->[2]->{'id'};
}

if ($entry eq 'import') {	if ($entry eq 'import') {
#	#
# Importing a library here	# Importing a library here
#	#
	my $location=$parser->get_text('/import');
	my $dir=$filename;
	$dir=~s\|[^/]*$\|\|;
	$location=&filelocation($dir,$location);

	my $importmode=$token->[2]->{'importmode'};
	if ($importmode eq 'problem') {
	# Import as problem/response
	$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
	} elsif ($importmode eq 'part') {
	# Import as part(s)
	$importedparts=1;
	# We need to get the original file and the imported file to get the part order correct
	# Good news: we do not need to worry about nested libraries, since parts cannot be nested
	# Load and inspect original file
	if ($#origfileimportpartids<0) {
	undef(%importedpartids);
	my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
	my $origfile=&getfile($origfilelocation);
	@origfileimportpartids=($origfile=~/<(part\|import)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
	}

	# Load and inspect imported file
	my $impfile=&getfile($location);
	my @impfilepartids=($impfile=~/<part[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
	if ($#impfilepartids>=0) {
	# This problem had parts
	$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
	} else {
	# Importing by turning a single problem into a problem part
	# It gets the import-tags ID as part-ID
	$unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
	$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
	}
	} else {
	# Normal import
	$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
	if (defined($token->[2]->{'id'})) {
	$unikey.='_'.$token->[2]->{'id'};
	}
	}

if ($depthcount<20) {	if ($depthcount<20) {
my $location=$parser->get_text('/import');
my $dir=$filename;
$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);
my $metadata =	my $metadata =
&metadata($uri,'keys', $location,$unikey,	&metadata($uri,'keys', $location,$unikey,
$depthcount+1);	$depthcount+1);
Line 8763 sub metadata {	Line 8719 sub metadata {
$metaentry{':'.$meta}=$metaentry{':'.$meta};	$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;	$metathesekeys{$meta}=1;
}	}
}
} else {	}
	} else {
	#
	# Not importing, some other kind of non-package, non-library start tag
	#
	$unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
	if (defined($token->[2]->{'id'})) {
	$unikey.='_'.$token->[2]->{'id'};
	}
if (defined($token->[2]->{'name'})) {	if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};	$unikey.='_'.$token->[2]->{'name'};
}	}
Line 8838 sub metadata {	Line 8802 sub metadata {
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));	grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
$metaentry{':packages'} = join(',',@uniq_packages);	$metaentry{':packages'} = join(',',@uniq_packages);

	if ($importedparts) {
	# We had imported parts and need to rebuild partorder
	$metaentry{':partorder'}='';
	$metathesekeys{'partorder'}=1;
	for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
	if ($origfileimportpartids[$index] eq 'part') {
	# original part, part of the problem
	$metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
	} else {
	# we have imported parts at this position
	$metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
	}
	}
	$metaentry{':partorder'}=~s/^\,//;
	}

$metaentry{':keys'} = join(',',keys(%metathesekeys));	$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
Line 9022 sub symbverify {	Line 9002 sub symbverify {
$thisurl =~ s/\?.+$//;	$thisurl =~ s/\?.+$//;
}	}
my $ids=$bighash{'ids_'.&clutter($thisurl)};	my $ids=$bighash{'ids_'.&clutter($thisurl)};
unless ($ids) {	unless ($ids) {
my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;	my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
$ids=$bighash{$idkey};	$ids=$bighash{$idkey};
}	}
if ($ids) {	if ($ids) {
# ------------------------------------------------------------------- Has ID(s)	# ------------------------------------------------------------------- Has ID(s)
Line 9038 sub symbverify {	Line 9018 sub symbverify {
eq $symb) {	eq $symb) {
if (($env{'request.role.adv'}) \|\|	if (($env{'request.role.adv'}) \|\|
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) \|\|	($bighash{'encrypted_'.$id} eq $env{'request.enc'}) \|\|
($thisurl eq '/adm/navmaps')) {	($thisurl eq '/adm/navmaps')) {
$okay=1;	$okay=1;
}	}
}	}
Line 10033 sub get_dns {	Line 10013 sub get_dns {
while (%alldns) {	while (%alldns) {
my ($dns) = keys(%alldns);	my ($dns) = keys(%alldns);
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
$ua->timeout(30);
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);	my $response=$ua->request($request);
delete($alldns{$dns});	delete($alldns{$dns});
Line 10125 sub get_dns {	Line 10104 sub get_dns {
foreach my $configline (@$file) {	foreach my $configline (@$file) {
next if ($configline =~ /^(\#\|\s*$ )/x);	next if ($configline =~ /^(\#\|\s*$ )/x);
chomp($configline);	chomp($configline);
if ($configline =~ /^\^/) {	if ($configline =~ /^\^/) {
if ($configline =~ /^\^([\w.\-]+)/) {	if ($configline =~ /^\^([\w.\-]+)/) {
$LC_dns_serv{$1} = 1;	$LC_dns_serv{$1} = 1;
}	}
Line 10212 sub get_dns {	Line 10191 sub get_dns {
}	}

sub unique_library {	sub unique_library {
#2x reverse removes all hostnames that appear more than once	#2x reverse removes all hostnames that appear more than once
my %unique = reverse &all_library();	my %unique = reverse &all_library();
return reverse %unique;	return reverse %unique;
}	}
Line 10242 sub get_dns {	Line 10221 sub get_dns {

sub get_unique_servers {	sub get_unique_servers {
my %unique = reverse &get_servers(@_);	my %unique = reverse &get_servers(@_);
return reverse %unique;	return reverse %unique;
}	}

sub host_domain {	sub host_domain {
Line 10549 BEGIN {	Line 10528 BEGIN {
}	}
}	}

# ---------------------------------------------------------- Read managers table
{
if (-e "$perlvar{'lonTabDir'}/managers.tab") {
if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) {
while (my $configline=<$config>) {
chomp($configline);
next if ($configline =~ /^\#/);
if (($configline =~ /^[\w\-]+$/) \|\| ($configline =~ /^[\w\-]+\:[\w\-]+$/)) {
$managerstab{$configline} = 1;
}
}
close($config);
}
}
}

# ------------- set up temporary directory	# ------------- set up temporary directory
{	{
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/';	$tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
Line 10802 $checkdefauth is optional (value is 1 if	Line 10765 $checkdefauth is optional (value is 1 if
authenticate user using default authentication method, and allow	authenticate user using default authentication method, and allow
account creation if username does not have account in the domain).	account creation if username does not have account in the domain).
$clientcancheckhost is optional (value is 1 if checking whether the	$clientcancheckhost is optional (value is 1 if checking whether the
server can host will occur on the client side in lonauth.pm).	server can host will occur on the client side in lonauth.pm).

=item *	=item *
X<homeserver()>	X<homeserver()>
Line 11458 splitting on '&', supports elements that	Line 11421 splitting on '&', supports elements that

=head2 Logging Routines	=head2 Logging Routines

	=over 4

These routines allow one to make log messages in the lonnet.log and	These routines allow one to make log messages in the lonnet.log and
lonnet.perm logfiles.	lonnet.perm logfiles.

=over 4

=item *	=item *

logtouch() : make sure the logfile, lonnet.log, exists	logtouch() : make sure the logfile, lonnet.log, exists
Line 11552 userfileupload(): main rotine for puttin	Line 11515 userfileupload(): main rotine for puttin
the filename is in $env{'form.'.$formname.'.filename'} and the	the filename is in $env{'form.'.$formname.'.filename'} and the
contents of the file is located in $env{'form.'.$formname}	contents of the file is located in $env{'form.'.$formname}
context - if coursedoc, store the file in the course of the active role	context - if coursedoc, store the file in the course of the active role
of the current user;	of the current user;
if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp	if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp
if 'canceloverwrite': delete file in tmp/overwrites directory	if 'canceloverwrite': delete file in tmp/overwrites directory
subdir - required - subdirectory to put the file in under ../userfiles/	subdir - required - subdirectory to put the file in under ../userfiles/
Line 11598 userspace, probably shouldn't be called	Line 11561 userspace, probably shouldn't be called
returns either the url of the uploaded file (/uploaded/....) if successful	returns either the url of the uploaded file (/uploaded/....) if successful
and /adm/notfound.html if unsuccessful (or an error message if context	and /adm/notfound.html if unsuccessful (or an error message if context
was 'overwrite').	was 'overwrite').


=item *	=item *

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

Removed from v.1.1056.4.33.2.1
changed lines
	Added in v.1.1115