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.670 and 1.695

version 1.670, 2005/10/28 21:51:50	version 1.695, 2006/01/11 07:32:21
Line 40 qw(%perlvar %hostname %badServerCache %i	Line 40 qw(%perlvar %hostname %badServerCache %i
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
%domaindescription %domain_auth_def %domain_auth_arg_def	%domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit	%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
%env);	$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
Line 49 use Apache::Constants qw(:common :http);	Line 49 use Apache::Constants qw(:common :http);
use HTML::LCParser;	use HTML::LCParser;
use HTML::Parser;	use HTML::Parser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );	use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;	use Cache::Memcached;
	use Digest::MD5;

my $readit;	my $readit;
my $max_connection_retries = 10; # Or some such value.	my $max_connection_retries = 10; # Or some such value.

Line 166 sub reply {	Line 167 sub reply {
unless (defined($hostname{$server})) { return 'no_such_host'; }	unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {	if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" $cmd to $server returned $answer</font>");	" $cmd to $server returned $answer</font>");
}	}
return $answer;	return $answer;
Line 190 sub reconlonc {	Line 191 sub reconlonc {
sleep 5;	sleep 5;
if (-e "$peerfile") { return; }	if (-e "$peerfile") { return; }
&logthis(	&logthis(
"<font color=blue>WARNING: $peerfile still not there, giving up</font>");	"<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING:".	"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");	" lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color=blue>WARNING: lonc not running, giving up</font>');	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}	}
}	}

Line 206 sub reconlonc {	Line 207 sub reconlonc {
sub critical {	sub critical {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless ($hostname{$server}) {	unless ($hostname{$server}) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");	" Critical message to unknown server ($server)</font>");
return 'no_such_host';	return 'no_such_host';
}	}
Line 240 sub critical {	Line 241 sub critical {
}	}
chomp($wcmd);	chomp($wcmd);
if ($wcmd eq $cmd) {	if ($wcmd eq $cmd) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Connection buffer $dfilename: $cmd</font>");	"Connection buffer $dfilename: $cmd</font>");
&logperm("D:$server:$cmd");	&logperm("D:$server:$cmd");
return 'con_delayed';	return 'con_delayed';
} else {	} else {
&logthis("<font color=red>CRITICAL:"	&logthis("<font color=\"red\">CRITICAL:"
." Critical connection failed: $server $cmd</font>");	." Critical connection failed: $server $cmd</font>");
&logperm("F:$server:$cmd");	&logperm("F:$server:$cmd");
return 'con_failed';	return 'con_failed';
Line 270 sub transfer_profile_to_env {	Line 271 sub transfer_profile_to_env {
my %Remove;	my %Remove;
for ($envi=0;$envi<=$#profile;$envi++) {	for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);	chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi]);	my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
$env{$envname} = $envvalue;	$env{$envname} = $envvalue;
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {	if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {	if ($time < time-300) {
Line 288 sub transfer_profile_to_env {	Line 289 sub transfer_profile_to_env {

sub appenv {	sub appenv {
my %newenv=@_;	my %newenv=@_;
foreach (keys %newenv) {	foreach my $key (keys(%newenv)) {
if (($newenv{$_}=~/^user\.role/) \|\| ($newenv{$_}=~/^user\.priv/)) {	if (($newenv{$key}=~/^user\.role/) \|\| ($newenv{$key}=~/^user\.priv/)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Attempt to modify environment ".$_." to ".$newenv{$_}	"Attempt to modify environment ".$key." to ".$newenv{$key}
.'</font>');	.'</font>');
delete($newenv{$_});	delete($newenv{$key});
} else {	} else {
$env{$_}=$newenv{$_};	$env{$key}=$newenv{$key};
}	}
}	}

Line 304 sub appenv {	Line 305 sub appenv {
return 'error: '.$!;	return 'error: '.$!;
}	}
unless (flock($lockfh,LOCK_EX)) {	unless (flock($lockfh,LOCK_EX)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
'Could not obtain exclusive lock in appenv: '.$!);	'Could not obtain exclusive lock in appenv: '.$!);
close($lockfh);	close($lockfh);
return 'error: '.$!;	return 'error: '.$!;
Line 322 sub appenv {	Line 323 sub appenv {
for (my $i=0; $i<=$#oldenv; $i++) {	for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);	chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {	if ($oldenv[$i] ne '') {
my ($name,$value)=split(/=/,$oldenv[$i]);	my ($name,$value)=split(/=/,$oldenv[$i],2);
unless (defined($newenv{$name})) {	unless (defined($newenv{$name})) {
$newenv{$name}=$value;	$newenv{$name}=$value;
}	}
Line 349 sub delenv {	Line 350 sub delenv {
my $delthis=shift;	my $delthis=shift;
my %newenv=();	my %newenv=();
if (($delthis=~/user\.role/) \|\| ($delthis=~/user\.priv/)) {	if (($delthis=~/user\.role/) \|\| ($delthis=~/user\.priv/)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);	"Attempt to delete from environment ".$delthis);
return 'error';	return 'error';
}	}
Line 360 sub delenv {	Line 361 sub delenv {
return 'error';	return 'error';
}	}
unless (flock($fh,LOCK_SH)) {	unless (flock($fh,LOCK_SH)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
'Could not obtain shared lock in delenv: '.$!);	'Could not obtain shared lock in delenv: '.$!);
close($fh);	close($fh);
return 'error: '.$!;	return 'error: '.$!;
Line 374 sub delenv {	Line 375 sub delenv {
return 'error';	return 'error';
}	}
unless (flock($fh,LOCK_EX)) {	unless (flock($fh,LOCK_EX)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
'Could not obtain exclusive lock in delenv: '.$!);	'Could not obtain exclusive lock in delenv: '.$!);
close($fh);	close($fh);
return 'error: '.$!;	return 'error: '.$!;
}	}
foreach (@oldenv) {	foreach my $cur_key (@oldenv) {
if ($_=~/^$delthis/) {	if ($cur_key=~/^$delthis/) {
my ($key,undef) = split('=',$_);	my ($key,undef) = split('=',$cur_key,2);
delete($env{$key});	delete($env{$key});
} else {	} else {
print $fh $_;	print $fh $cur_key;
}	}
}	}
close($fh);	close($fh);
Line 1064 sub repcopy {	Line 1065 sub repcopy {
if ($response->is_error()) {	if ($response->is_error()) {
unlink($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
&logthis("<font color=blue>WARNING:"	&logthis("<font color=\"blue\">WARNING:"
." LWP get: $message: $filename</font>");	." LWP get: $message: $filename</font>");
return 'unavailable';	return 'unavailable';
} else {	} else {
Line 1074 sub repcopy {	Line 1075 sub repcopy {
if ($mresponse->is_error()) {	if ($mresponse->is_error()) {
unlink($filename.'.meta');	unlink($filename.'.meta');
&logthis(	&logthis(
"<font color=yellow>INFO: No metadata: $filename</font>");	"<font color=\"yellow\">INFO: No metadata: $filename</font>");
}	}
}	}
rename($transname,$filename);	rename($transname,$filename);
Line 1279 sub clean_filename {	Line 1280 sub clean_filename {
}	}

# --------------- Take an uploaded file and put it into the userfiles directory	# --------------- Take an uploaded file and put it into the userfiles directory
# input: name of form element, coursedoc=1 means this is for the course	# input: $formname - the contents of the file are in $env{"form.$formname"}
# output: url of file in userspace	# the desired filenam is in $env{"form.$formname"}
	# $coursedoc - if true up to the current course
	# if false
	# $subdir - directory in userfile to store the file into
	# $parser, $allfiles, $codebase - unknown
	#
	# output: url of file in userspace, or error: <message>
	# or /adm/notfound.html if failure to upload occurse


sub userfileupload {	sub userfileupload {
Line 1542 sub flushcourselogs {	Line 1550 sub flushcourselogs {
} else {	} else {
&logthis('Failed to flush log buffer for '.$crsid);	&logthis('Failed to flush log buffer for '.$crsid);
if (length($courselogs{$crsid})>40000) {	if (length($courselogs{$crsid})>40000) {
&logthis("<font color=blue>WARNING: Buffer for ".$crsid.	&logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
" exceeded maximum size, deleting.</font>");	" exceeded maximum size, deleting.</font>");
delete $courselogs{$crsid};	delete $courselogs{$crsid};
}	}
Line 1852 sub courseiddump {	Line 1860 sub courseiddump {
# ---------------------------------------------------------- DC e-mail	# ---------------------------------------------------------- DC e-mail

sub dcmailput {	sub dcmailput {
my ($domain,$msgid,$contents,$server)=@_;	my ($domain,$msgid,$message,$server)=@_;
my $status = &Apache::lonnet::critical(	my $status = &Apache::lonnet::critical(
'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.	'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
&Apache::lonnet::escape($$contents{$server}),$server);	&Apache::lonnet::escape($message),$server);
return $status;	return $status;
}	}

sub dcmaildump {	sub dcmaildump {
my ($dom,$startdate,$enddate,$senders) = @_;	my ($dom,$startdate,$enddate,$senders) = @_;
my %returnhash=();	my %returnhash=();
foreach my $tryserver (keys(%libserv)) {	if (exists($domain_primary{$dom})) {
if ($hostdom{$tryserver} eq $dom) {	my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
%{$returnhash{$tryserver}}=();	&escape($enddate).':';
my $cmd='dcmaildump:'.$dom.':'.	my @esc_senders=map { &escape($_)} @$senders;
&escape($startdate).':'.&escape($enddate).':';	$cmd.=&escape(join('&',@esc_senders));
my @esc_senders=map { &escape($_)} @$senders;	foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
$cmd.=&escape(join('&',@esc_senders));	my ($key,$value) = split(/\=/,$_);
foreach (split(/\&/,&reply($cmd,$tryserver))) {	if (($key) && ($value)) {
my ($key,$value) = split(/\=/,$_);	$returnhash{&unescape($key)} = &unescape($value);
if (($key) && ($value)) {
$returnhash{$tryserver}{&unescape($key)} = &unescape($value);
}
}	}
}	}
}	}
Line 1953 sub checkout {	Line 1958 sub checkout {
$now.'&'.$ENV{'REMOTE_ADDR'});	$now.'&'.$ENV{'REMOTE_ADDR'});
my $token=&reply('tmpput:'.$infostr,$lonhost);	my $token=&reply('tmpput:'.$infostr,$lonhost);
if ($token=~/^error\:/) {	if ($token=~/^error\:/) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.	"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");	"</font>");
return '';	return '';
Line 1969 sub checkout {	Line 1974 sub checkout {
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {	unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';	return '';
} else {	} else {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.	"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");	"</font>");
}	}
Line 1979 sub checkout {	Line 1984 sub checkout {
$token)) ne 'ok') {	$token)) ne 'ok') {
return '';	return '';
} else {	} else {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.	"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");	"</font>");
}	}
Line 2574 sub rolesinit {	Line 2579 sub rolesinit {
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);	my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return ''; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return ''; }
my %allroles=();	my %allroles=();
	my %allgroups=();
my $now=time;	my $now=time;
my $userroles="user.login.time=$now\n";	my $userroles="user.login.time=$now\n";
	my $group_privs;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {	foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef_/) {	if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);	my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;	$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart);	my ($trole,$tend,$tstart,$group_privs);
if ($role=~/^cr/) {	if ($role=~/^cr/) {
if ($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|) {	if ($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|) {
($trole,my $trest)=($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|);	($trole,my $trest)=($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|);
Line 2590 sub rolesinit {	Line 2597 sub rolesinit {
} else {	} else {
$trole=$role;	$trole=$role;
}	}
	} elsif ($role =~ m\|^gr/\|) {
	($trole,$tend,$tstart) = split(/_/,$role);
	($trole,$group_privs) = split(/\//,$trole);
	$group_privs = &unescape($group_privs);
} else {	} else {
($trole,$tend,$tstart)=split(/_/,$role);	($trole,$tend,$tstart)=split(/_/,$role);
}	}
Line 2601 sub rolesinit {	Line 2612 sub rolesinit {
my ($tdummy,$tdomain,$trest)=split(/\//,$area);	my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {	if ($trole =~ /^cr\//) {
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);	&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
	} elsif ($trole eq 'gr') {
	&group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
} else {	} else {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}	}
}	}
}	}
}	}
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);	my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
$userroles.='user.adv='.$adv."\n".	$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";	'user.author='.$author."\n";
$env{'user.adv'}=$adv;	$env{'user.adv'}=$adv;
Line 2649 sub custom_roleprivs {	Line 2662 sub custom_roleprivs {
}	}
}	}

	sub group_roleprivs {
	my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
	my $access = 1;
	my $now = time;
	if (($tend!=0) && ($tend<$now)) { $access = 0; }
	if (($tstart!=0) && ($tstart>$now)) { $access=0; }
	if ($access) {
	my ($course,$group) = ($area =~ m\|(/\w+/\w+)/([^/]+)$\|);
	$$allgroups{$course}{$group} .=':'.$group_privs;
	}
	}

sub standard_roleprivs {	sub standard_roleprivs {
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;	my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
Line 2669 sub standard_roleprivs {	Line 2693 sub standard_roleprivs {
}	}

sub set_userprivs {	sub set_userprivs {
my ($userroles,$allroles) = @_;	my ($userroles,$allroles,$allgroups) = @_;
my $author=0;	my $author=0;
my $adv=0;	my $adv=0;
	my %grouproles = ();
	if (keys(%{$allgroups}) > 0) {
	foreach my $role (keys %{$allroles}) {
	my ($trole,$area,$sec,$extendedarea);
	if ($role =~ m\|^(\w+)\.(/\w+/\w+)(/?\w*)\|) {
	$trole = $1;
	$area = $2;
	$sec = $3;
	$extendedarea = $area.$sec;
	if (exists($$allgroups{$area})) {
	foreach my $group (keys(%{$$allgroups{$area}})) {
	my $spec = $trole.'.'.$extendedarea;
	$grouproles{$spec.'.'.$area.'/'.$group} =
	$$allgroups{$area}{$group};
	}
	}
	}
	}
	}
	foreach (keys(%grouproles)) {
	$$allroles{$_} = $grouproles{$_};
	}
foreach (keys %{$allroles}) {	foreach (keys %{$allroles}) {
my %thesepriv=();	my %thesepriv=();
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
Line 2971 sub tmpput {	Line 3017 sub tmpput {

# ------------------------------------------------------------ tmpget interface	# ------------------------------------------------------------ tmpget interface
sub tmpget {	sub tmpget {
my ($token)=@_;	my ($token,$server)=@_;
my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});	if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
	my $rep=&reply("tmpget:$token",$server);
my %returnhash;	my %returnhash;
foreach my $item (split(/\&/,$rep)) {	foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);	my ($key,$value)=split(/=/,$item);
Line 2981 sub tmpget {	Line 3028 sub tmpget {
return %returnhash;	return %returnhash;
}	}

	# ------------------------------------------------------------ tmpget interface
	sub tmpdel {
	my ($token,$server)=@_;
	if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
	return &reply("tmpdel:$token",$server);
	}

# ---------------------------------------------- Custom access rule evaluation	# ---------------------------------------------- Custom access rule evaluation

sub customaccess {	sub customaccess {
Line 3023 sub allowed {	Line 3077 sub allowed {
my $orguri=$uri;	my $orguri=$uri;
$uri=&declutter($uri);	$uri=&declutter($uri);



if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }	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 !~ m\|/bulletinboard$\|))	if (((($uri=~/^adm\//) && ($uri !~ m\|/bulletinboard$\|))
Line 3071 sub allowed {	Line 3123 sub allowed {
if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {	if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
# uri is the requested domain in this case.	# uri is the requested domain in this case.
# comparison to 'request.role.domain' shows if the user has selected	# comparison to 'request.role.domain' shows if the user has selected
# a role of dc for the domain in question.	# a role of dc for the domain in question.
return 'F' if ($uri eq $env{'request.role.domain'});	return 'F' if ($uri eq $env{'request.role.domain'});
}	}

Line 3102 sub allowed {	Line 3154 sub allowed {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

	# Group: uri itself is a group
	my $groupuri=$uri;
	$groupuri=~s/^([^\/])/\/$1/;
	if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}
	=~/\Q$priv\E\&([^\:]*)/) {
	$thisallowed.=$1;
	}

# URI is an uploaded document for this course, default permissions don't matter	# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs	# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {	if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {
$thisallowed='';	$thisallowed='';
my $refuri=$env{'httpref.'.$orguri};	my ($match)=&is_on_map($uri);
if ($refuri) {	if ($match) {
if ($refuri =~ m\|^/adm/\|) {	if ($env{'user.priv.'.$env{'request.role'}.'./'}
$thisallowed='F';	=~/\Q$priv\E\&([^\:]*)/) {
} else {	$thisallowed.=$1;
$refuri=&declutter($refuri);	}
my ($match) = &is_on_map($refuri);	} else {
if ($match) {	my $refuri=$env{'httpref.'.$orguri};
	if ($refuri) {
	if ($refuri =~ m\|^/adm/\|) {
$thisallowed='F';	$thisallowed='F';
	} else {
	$refuri=&declutter($refuri);
	my ($match) = &is_on_map($refuri);
	if ($match) {
	$thisallowed='F';
	}
}	}
}	}
} else {	}
$thisallowed='';
}
}	}

# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.
Line 3287 sub allowed {	Line 3353 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/) {
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'},	if ($priv ne 'pch') {
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
$env{'request.course.id'});	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
	$env{'request.course.id'});
	}
return '';	return '';
}	}

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/) {
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'},	if ($priv ne 'pch') {
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
$env{'request.course.id'});	'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
	$env{'request.course.id'});
	}
return '';	return '';
}	}
}	}
Line 3307 sub allowed {	Line 3377 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/) {
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'},	if ($priv ne 'pch') {
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
return '';	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
	}
	return '';
}	}
}	}

Line 3340 sub is_on_map {	Line 3412 sub is_on_map {
my $filename=$uriparts[$#uriparts];	my $filename=$uriparts[$#uriparts];
my $pathname=$uri;	my $pathname=$uri;
$pathname=~s\|/\Q$filename\E$\|\|;	$pathname=~s\|/\Q$filename\E$\|\|;
$pathname=~s/^adm\/wrapper\///;	$pathname=~s/^adm\/wrapper\///;
	$pathname=~s/^adm\/coursedocs\/showdoc\///;
#Trying to find the conditional for the file	#Trying to find the conditional for the file
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~	my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
/\&\Q$filename\E\:([\d\\|]+)\&/);	/\&\Q$filename\E\:([\d\\|]+)\&/);
Line 3646 sub auto_instcode_format {	Line 3719 sub auto_instcode_format {
return $response;	return $response;
}	}

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

	sub get_coursegroups {
	my ($cdom,$cnum,$group) = @_;
	return(&dump('coursegroups',$cdom,$cnum,$group));
	}

	sub modify_coursegroup {
	my ($cdom,$cnum,$groupsettings) = @_;
	return(&put('coursegroups',$groupsettings,$cdom,$cnum));
	}

	sub modify_group_roles {
	my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
	my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
	my $role = 'gr/'.&escape($userprivs);
	my ($uname,$udom) = split(/:/,$user);
	my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
	if ($result eq 'ok') {
	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
	}

	return $result;
	}

	sub modify_coursegroup_membership {
	my ($cdom,$cnum,$membership) = @_;
	my $result = &put('groupmembership',$membership,$cdom,$cnum);
	return $result;
	}

	sub get_active_groups {
	my ($udom,$uname,$cdom,$cnum) = @_;
	my $now = time;
	my %groups = ();
	foreach my $key (keys(%env)) {
	if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
	my ($start,$end) = split(/\./,$env{$key});
	if (($end!=0) && ($end<$now)) { next; }
	if (($start!=0) && ($start>$now)) { next; }
	if ($1 eq $cdom && $2 eq $cnum) {
	$groups{$3} = $env{$key} ;
	}
	}
	}
	return %groups;
	}

	sub get_group_membership {
	my ($cdom,$cnum,$group) = @_;
	return(&dump('groupmembership',$cdom,$cnum,$group));
	}

	sub get_users_groups {
	my ($udom,$uname,$courseid) = @_;
	my $cachetime=1800;
	$courseid=~s/\_/\//g;
	$courseid=~s/^(\w)/\/$1/;

	my $hashid="$udom:$uname:$courseid";
	my ($result,$cached)=&is_cached_new('getgroups',$hashid);
	if (defined($cached)) { return $result; }

	my %roleshash = &dump('roles',$udom,$uname,$courseid);
	my ($tmp) = keys(%roleshash);
	if ($tmp=~/^error:/) {
	&logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
	return '';
	} else {
	my $grouplist;
	foreach my $key (keys %roleshash) {
	if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
	unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership
	$grouplist .= $1.':';
	}
	}
	}
	$grouplist =~ s/:$//;
	return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
	}
	}

	sub devalidate_getgroups_cache {
	my ($udom,$uname,$cdom,$cnum)=@_;
	my $courseid = $cdom.'_'.$cnum;
	$courseid=~s/\_/\//g;
	$courseid=~s/^(\w)/\/$1/;
	my $hashid="$udom:$uname:$courseid";
	&devalidate_cache_new('getgroups',$hashid);
	}

# ------------------------------------------------------------------ Plain Text	# ------------------------------------------------------------------ Plain Text

sub plaintext {	sub plaintext {
my $short=shift;	my $short=shift;
return &mt($prp{$short});	return &Apache::lonlocal::mt($prp{$short});
}	}

# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role
Line 3668 sub assignrole {	Line 3832 sub assignrole {
return 'refused';	return 'refused';
}	}
$mrole='cr';	$mrole='cr';
	} elsif ($role =~ /^gr\//) {
	my $cwogrp=$url;
	$cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
	unless (&allowed('mdg',$cwogrp)) {
	&logthis('Refused group assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
	$mrole='gr';
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
Line 3828 sub modifyuser {	Line 4002 sub modifyuser {
}	}
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; }
	&devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.	$last.', '.$gene.' by '.
Line 3968 sub createcourse {	Line 4143 sub createcourse {
return 'refused';	return 'refused';
}	}
# ------------------------------------------------------------------- Create ID	# ------------------------------------------------------------------- Create ID
my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).	my $uname=int(1+rand(9)).
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
# ----------------------------------------------- Make sure that does not exist	# ----------------------------------------------- Make sure that does not exist
my $uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
Line 4476 sub get_userresdata {	Line 4653 sub get_userresdata {
}	}
#error 2 occurs when the .db doesn't exist	#error 2 occurs when the .db doesn't exist
if ($tmp!~/error: 2 /) {	if ($tmp!~/error: 2 /) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" Trying to get resource data for ".	" Trying to get resource data for ".
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
Line 4630 sub EXT {	Line 4807 sub EXT {
# ------------------------------------------------------------- request.browser	# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {	if ($space eq 'browser') {
if ($qualifier eq 'textremote') {	if ($qualifier eq 'textremote') {
if (&mt('textual_remote_display') eq 'on') {	if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
return 1;	return 1;
} else {	} else {
return 0;	return 0;
Line 4647 sub EXT {	Line 4824 sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};	return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {	} elsif ($realm eq 'resource') {

my $section;
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {	if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
}	}

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

	if ($space eq 'map') {
	my ($map) = &decode_symb($symbparm);
	return &symbread($map);
	}

	my ($section, $group, @groups);
my ($courselevelm,$courselevel);	my ($courselevelm,$courselevel);
if ($symbparm && defined($courseid) &&	if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {	$courseid eq $env{'request.course.id'}) {
Line 4667 sub EXT {	Line 4855 sub EXT {
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'};
	@groups=&sort_course_groups($env{'request.course.groups'},$courseid);
	if (@groups > 0) {
	@groups = sort(@groups);
	}
} else {	} else {
if (! defined($usection)) {	if (! defined($usection)) {
$section=&getsection($udom,$uname,$courseid);	$section=&getsection($udom,$uname,$courseid);
} else {	} else {
$section = $usection;	$section = $usection;
}	}
	my $grouplist = &get_users_groups($udom,$uname,$courseid);
	if ($grouplist) {
	@groups=&sort_course_groups($grouplist,$courseid);
	}
}	}

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 4688 sub EXT {	Line 4884 sub EXT {
my $userreply=&resdata($uname,$udom,'user',	my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,	($courselevelr,$courselevelm,
$courselevel));	$courselevel));

if (defined($userreply)) { return $userreply; }	if (defined($userreply)) { return $userreply; }

# ------------------------------------------------ second, check some of course	# ------------------------------------------------ second, check some of course
	my $coursereply;
	if (@groups > 0) {
	$coursereply = &check_group_parms($courseid,\@groups,$symbparm,
	$mapparm,$spacequalifierrest);
	if (defined($coursereply)) { return $coursereply; }
	}

my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	$coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',
($seclevelr,$seclevelm,$seclevel,	($seclevelr,$seclevelm,$seclevel,
Line 4768 sub EXT {	Line 4969 sub EXT {
return '';	return '';
}	}

	sub check_group_parms {
	my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
	my @groupitems = ();
	my $resultitem;
	my @levels = ($symbparm,$mapparm,$what);
	foreach my $group (@{$groups}) {
	foreach my $level (@levels) {
	my $item = $courseid.'.['.$group.'].'.$level;
	push(@groupitems,$item);
	}
	}
	my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
	$env{'course.'.$courseid.'.domain'},
	'course',@groupitems);
	return $coursereply;
	}

	sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
	my ($grouplist,$courseid) = @_;
	my @groups = split/:/,$grouplist;
	if (@groups > 1) {
	@groups = sort(@groups);
	}
	return @groups;
	}

sub packages_tab_default {	sub packages_tab_default {
my ($uri,$varname)=@_;	my ($uri,$varname)=@_;
my (undef,$part,$name)=split(/\./,$varname);	my (undef,$part,$name)=split(/\./,$varname);
Line 4810 sub metadata {	Line 5037 sub metadata {
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\|	if (($uri eq '') \|\|
(($uri =~ m\|^/*adm/\|) &&	(($uri =~ m\|^/*adm/\|) &&
($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)) \|\|	($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)
	&& ($uri !~ m\|^adm/coursedocs/\|) && ($uri !~ m\|^adm/wrapper/\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
($uri =~ m\|home/[^/]+/public_html/\|)) {	($uri =~ m\|home/[^/]+/public_html/\|)) {
return undef;	return undef;
Line 5128 sub symbverify {	Line 5356 sub symbverify {
my $thisfn=$thisurl;	my $thisfn=$thisurl;
# wrapper not part of symbs	# wrapper not part of symbs
$thisfn=~s/^\/adm\/wrapper//;	$thisfn=~s/^\/adm\/wrapper//;
	$thisfn=~s/^\/adm\/coursedocs\/showdoc\///;
$thisfn=&declutter($thisfn);	$thisfn=&declutter($thisfn);
# 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; }
Line 5182 sub symbclean {	Line 5411 sub symbclean {
# remove wrapper	# remove wrapper

$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;	$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
	$symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
return $symb;	return $symb;
}	}

Line 5258 sub symbread {	Line 5488 sub symbread {
if ( ($thisfn =~ m/^(uploaded\|editupload)\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {	if ( ($thisfn =~ m/^(uploaded\|editupload)\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {
$targetfn = 'adm/wrapper/'.$thisfn;	$targetfn = 'adm/wrapper/'.$thisfn;
}	}
	if ($targetfn =~ m\|^adm/wrapper/(ext/.*)\|) {
	$targetfn=$1;
	}
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
$syval=$hash{$targetfn};	$syval=$hash{$targetfn};
Line 5371 sub numval3 {	Line 5604 sub numval3 {
return $total;	return $total;
}	}

	sub digest {
	my ($data)=@_;
	my $digest=&Digest::MD5::md5($data);
	my ($a,$b,$c,$d)=unpack("iiii",$digest);
	my ($e,$f);
	{
	use integer;
	$e=($a+$b);
	$f=($c+$d);
	if ($_64bit) {
	$e=(($e<<32)>>32);
	$f=(($f<<32)>>32);
	}
	}
	if (wantarray) {
	return ($e,$f);
	} else {
	my $g;
	{
	use integer;
	$g=($e+$f);
	if ($_64bit) {
	$g=(($g<<32)>>32);
	}
	}
	return $g;
	}
	}

sub latest_rnd_algorithm_id {	sub latest_rnd_algorithm_id {
return '64bit4';	return '64bit5';
}	}

sub get_rand_alg {	sub get_rand_alg {
Line 5412 sub rndseed {	Line 5674 sub rndseed {
if (!$username) { $username=$wusername }	if (!$username) { $username=$wusername }
my $which=&get_rand_alg();	my $which=&get_rand_alg();
if (defined(&getCODE())) {	if (defined(&getCODE())) {
if ($which eq '64bit4') {	if ($which eq '64bit5') {
	return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
	} elsif ($which eq '64bit4') {
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
} else {	} else {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
}	}
	} elsif ($which eq '64bit5') {
	return &rndseed_64bit5($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit4') {	} elsif ($which eq '64bit4') {
return &rndseed_64bit4($symb,$courseid,$domain,$username);	return &rndseed_64bit4($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit3') {	} elsif ($which eq '64bit3') {
Line 5539 sub rndseed_64bit4 {	Line 5805 sub rndseed_64bit4 {
}	}
}	}

	sub rndseed_64bit5 {
	my ($symb,$courseid,$domain,$username)=@_;
	my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
	return "$num1:$num2";
	}

sub rndseed_CODE_64bit {	sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
{	{
Line 5577 sub rndseed_CODE_64bit4 {	Line 5849 sub rndseed_CODE_64bit4 {
}	}
}	}

	sub rndseed_CODE_64bit5 {
	my ($symb,$courseid,$domain,$username)=@_;
	my $code = &getCODE();
	my ($num1,$num2)=&digest("$symb,$courseid,$code");
	return "$num1:$num2";
	}

sub setup_random_from_rndseed {	sub setup_random_from_rndseed {
my ($rndseed)=@_;	my ($rndseed)=@_;
if ($rndseed =~/([,:])/) {	if ($rndseed =~/([,:])/) {
Line 5867 sub declutter {	Line 6146 sub declutter {
$thisfn=~s/^\///;	$thisfn=~s/^\///;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;	$thisfn=~s/\?.+$//;
	$thisfn=~s\|^adm/wrapper/\|\|;
	$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
return $thisfn;	return $thisfn;
}	}

Line 5877 sub clutter {	Line 6158 sub clutter {
unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {	unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
	if ($thisfn !~m\|/adm\|) {
	if ($thisfn =~ m\|/ext/\|) {
	$thisfn='/adm/wrapper'.$thisfn;
	} else {
	my ($ext) = ($thisfn =~ /\.(\w+)$/);
	my $embstyle=&Apache::loncommon::fileembstyle($ext);
	if (($embstyle eq 'img')
	\|\| ($embstyle eq 'emb')
	\|\| ($embstyle eq 'wrp')) {
	$thisfn='/adm/wrapper'.$thisfn;
	} elsif ($embstyle eq 'ssi') {
	#do nothing with these
	} elsif ($thisfn!~/\.(sequence\|page)$/) {
	$thisfn='/adm/coursedocs/showdoc'.$thisfn;
	}
	}
	}
return $thisfn;	return $thisfn;
}	}

Line 5915 sub thaw_unescape {	Line 6213 sub thaw_unescape {
return &unescape($value);	return &unescape($value);
}	}

sub mod_perl_version {
return 1;
if (defined($perlvar{'MODPERL2'})) {
return 2;
}
}

sub correct_line_ends {	sub correct_line_ends {
my ($result)=@_;	my ($result)=@_;
$$result =~s/\r\n/\n/mg;	$$result =~s/\r\n/\n/mg;
Line 5992 BEGIN {	Line 6283 BEGIN {
# next if /^\#/;	# next if /^\#/;
chomp;	chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg,	my ($domain, $domain_description, $def_auth, $def_auth_arg,
$def_lang, $city, $longi, $lati) = split(/:/,$_);	$def_lang, $city, $longi, $lati, $primary) = 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;
Line 6000 BEGIN {	Line 6291 BEGIN {
$domain_city{$domain}=$city;	$domain_city{$domain}=$city;
$domain_longi{$domain}=$longi;	$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;	$domain_lati{$domain}=$lati;
	$domain_primary{$domain}=$primary;

# &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 6120 $processmarker='_'.time.'_'.$perlvar{'lo	Line 6412 $processmarker='_'.time.'_'.$perlvar{'lo
$dumpcount=0;	$dumpcount=0;

&logtouch();	&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');	&logthis('<font color="yellow">INFO: Read configuration</font>');
$readit=1;	$readit=1;
{	{
use integer;	use integer;

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

Removed from v.1.670
changed lines
	Added in v.1.695