--- loncom/lonnet/perl/lonnet.pm 2005/10/28 21:51:50 1.670 +++ loncom/lonnet/perl/lonnet.pm 2006/01/05 19:39:52 1.683.2.5 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.670 2005/10/28 21:51:50 albertel Exp $ +# $Id: lonnet.pm,v 1.683.2.5 2006/01/05 19:39:52 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -40,8 +40,8 @@ qw(%perlvar %hostname %badServerCache %i %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %domaindescription %domain_auth_def %domain_auth_arg_def - %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit - %env); + %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary + $tmpdir $_64bit %env); use IO::Socket; use GDBM_File; @@ -49,10 +49,11 @@ use Apache::Constants qw(:common :http); use HTML::LCParser; use HTML::Parser; use Fcntl qw(:flock); -use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; +use Digest::MD5; + my $readit; my $max_connection_retries = 10; # Or some such value. @@ -166,7 +167,7 @@ sub reply { unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { - &logthis("WARNING:". + &logthis("WARNING:". " $cmd to $server returned $answer"); } return $answer; @@ -190,14 +191,14 @@ sub reconlonc { sleep 5; if (-e "$peerfile") { return; } &logthis( - "WARNING: $peerfile still not there, giving up"); + "WARNING: $peerfile still not there, giving up"); } else { &logthis( - "WARNING:". + "WARNING:". " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('WARNING: lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } @@ -206,7 +207,7 @@ sub reconlonc { sub critical { my ($cmd,$server)=@_; unless ($hostname{$server}) { - &logthis("WARNING:". + &logthis("WARNING:". " Critical message to unknown server ($server)"); return 'no_such_host'; } @@ -240,12 +241,12 @@ sub critical { } chomp($wcmd); if ($wcmd eq $cmd) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Connection buffer $dfilename: $cmd"); &logperm("D:$server:$cmd"); return 'con_delayed'; } else { - &logthis("CRITICAL:" + &logthis("CRITICAL:" ." Critical connection failed: $server $cmd"); &logperm("F:$server:$cmd"); return 'con_failed'; @@ -290,7 +291,7 @@ sub appenv { my %newenv=@_; foreach (keys %newenv) { if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Attempt to modify environment ".$_." to ".$newenv{$_} .''); delete($newenv{$_}); @@ -304,7 +305,7 @@ sub appenv { return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain exclusive lock in appenv: '.$!); close($lockfh); return 'error: '.$!; @@ -349,7 +350,7 @@ sub delenv { my $delthis=shift; my %newenv=(); if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); return 'error'; } @@ -360,7 +361,7 @@ sub delenv { return 'error'; } unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain shared lock in delenv: '.$!); close($fh); return 'error: '.$!; @@ -374,7 +375,7 @@ sub delenv { return 'error'; } unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain exclusive lock in delenv: '.$!); close($fh); return 'error: '.$!; @@ -1064,7 +1065,7 @@ sub repcopy { if ($response->is_error()) { unlink($transname); my $message=$response->status_line; - &logthis("WARNING:" + &logthis("WARNING:" ." LWP get: $message: $filename"); return 'unavailable'; } else { @@ -1074,7 +1075,7 @@ sub repcopy { if ($mresponse->is_error()) { unlink($filename.'.meta'); &logthis( - "INFO: No metadata: $filename"); + "INFO: No metadata: $filename"); } } rename($transname,$filename); @@ -1542,7 +1543,7 @@ sub flushcourselogs { } else { &logthis('Failed to flush log buffer for '.$crsid); if (length($courselogs{$crsid})>40000) { - &logthis("WARNING: Buffer for ".$crsid. + &logthis("WARNING: Buffer for ".$crsid. " exceeded maximum size, deleting."); delete $courselogs{$crsid}; } @@ -1852,28 +1853,25 @@ sub courseiddump { # ---------------------------------------------------------- DC e-mail sub dcmailput { - my ($domain,$msgid,$contents,$server)=@_; + my ($domain,$msgid,$message,$server)=@_; my $status = &Apache::lonnet::critical( 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='. - &Apache::lonnet::escape($$contents{$server}),$server); + &Apache::lonnet::escape($message),$server); return $status; } sub dcmaildump { my ($dom,$startdate,$enddate,$senders) = @_; - my %returnhash=(); - foreach my $tryserver (keys(%libserv)) { - if ($hostdom{$tryserver} eq $dom) { - %{$returnhash{$tryserver}}=(); - my $cmd='dcmaildump:'.$dom.':'. - &escape($startdate).':'.&escape($enddate).':'; - my @esc_senders=map { &escape($_)} @$senders; - $cmd.=&escape(join('&',@esc_senders)); - foreach (split(/\&/,&reply($cmd,$tryserver))) { - my ($key,$value) = split(/\=/,$_); - if (($key) && ($value)) { - $returnhash{$tryserver}{&unescape($key)} = &unescape($value); - } + my %returnhash=(); + if (exists($domain_primary{$dom})) { + my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. + &escape($enddate).':'; + my @esc_senders=map { &escape($_)} @$senders; + $cmd.=&escape(join('&',@esc_senders)); + foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { + my ($key,$value) = split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)} = &unescape($value); } } } @@ -1953,7 +1951,7 @@ sub checkout { $now.'&'.$ENV{'REMOTE_ADDR'}); my $token=&reply('tmpput:'.$infostr,$lonhost); if ($token=~/^error\:/) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. ""); return ''; @@ -1969,7 +1967,7 @@ sub checkout { unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { return ''; } else { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } @@ -1979,7 +1977,7 @@ sub checkout { $token)) ne 'ok') { return ''; } else { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } @@ -2574,15 +2572,17 @@ sub rolesinit { my $rolesdump=reply("dump:$domain:$username:roles",$authhost); if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } my %allroles=(); + my %allgroups=(); my $now=time; my $userroles="user.login.time=$now\n"; + my $group_privs; if ($rolesdump ne '') { foreach (split(/&/,$rolesdump)) { if ($_!~/^rolesdef_/) { my ($area,$role)=split(/=/,$_); $area=~s/\_\w\w$//; - my ($trole,$tend,$tstart); + my ($trole,$tend,$tstart,$group_privs); if ($role=~/^cr/) { if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); @@ -2590,6 +2590,10 @@ sub rolesinit { } else { $trole=$role; } + } elsif ($role =~ m|^gr/|) { + ($trole,$tend,$tstart) = split(/_/,$role); + ($trole,$group_privs) = split(/\//,$trole); + $group_privs = &unescape($group_privs); } else { ($trole,$tend,$tstart)=split(/_/,$role); } @@ -2601,13 +2605,15 @@ sub rolesinit { my ($tdummy,$tdomain,$trest)=split(/\//,$area); if ($trole =~ /^cr\//) { &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); + } elsif ($trole eq 'gr') { + &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart); } else { &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". 'user.author='.$author."\n"; $env{'user.adv'}=$adv; @@ -2649,6 +2655,17 @@ 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 { my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_; @@ -2669,9 +2686,31 @@ sub standard_roleprivs { } sub set_userprivs { - my ($userroles,$allroles) = @_; + my ($userroles,$allroles,$allgroups) = @_; my $author=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}) { my %thesepriv=(); if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } @@ -2971,8 +3010,9 @@ sub tmpput { # ------------------------------------------------------------ tmpget interface sub tmpget { - my ($token)=@_; - my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'}); + my ($token,$server)=@_; + if (!defined($server)) { $server = $perlvar{'lonHostID'}; } + my $rep=&reply("tmpget:$token",$server); my %returnhash; foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); @@ -2981,6 +3021,13 @@ sub tmpget { return %returnhash; } +# ------------------------------------------------------------ tmpget interface +sub tmpdel { + my ($token,$server)=@_; + if (!defined($server)) { $server = $perlvar{'lonHostID'}; } + return &reply("tmpdel:$token",$server); +} + # ---------------------------------------------- Custom access rule evaluation sub customaccess { @@ -3023,8 +3070,6 @@ sub allowed { my $orguri=$uri; $uri=&declutter($uri); - - if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) @@ -3071,7 +3116,7 @@ sub allowed { if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) { # uri is the requested domain in this case. # 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'}); } @@ -3102,24 +3147,38 @@ sub allowed { $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 # not allowing 'edit' access (editupload) to uploaded course docs if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { $thisallowed=''; - my $refuri=$env{'httpref.'.$orguri}; - if ($refuri) { - if ($refuri =~ m|^/adm/|) { - $thisallowed='F'; - } else { - $refuri=&declutter($refuri); - my ($match) = &is_on_map($refuri); - if ($match) { + my ($match)=&is_on_map($uri); + if ($match) { + if ($env{'user.priv.'.$env{'request.role'}.'./'} + =~/\Q$priv\E\&([^\:]*)/) { + $thisallowed.=$1; + } + } else { + my $refuri=$env{'httpref.'.$orguri}; + if ($refuri) { + if ($refuri =~ m|^/adm/|) { $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. @@ -3287,17 +3346,21 @@ sub allowed { my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\Q$rolecode\E/) { - &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, - 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. - $env{'request.course.id'}); + if ($priv ne 'pch') { + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. + $env{'request.course.id'}); + } return ''; } if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} =~/\Q$unamedom\E/) { - &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, - 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. - $env{'request.course.id'}); + if ($priv ne 'pch') { + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. + 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. + $env{'request.course.id'}); + } return ''; } } @@ -3307,9 +3370,11 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$env{'request.role'}))[0]; if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { - &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, - 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); - return ''; + if ($priv ne 'pch') { + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); + } + return ''; } } @@ -3646,11 +3711,98 @@ sub auto_instcode_format { 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); + 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 sub plaintext { my $short=shift; - return &mt($prp{$short}); + return &Apache::lonlocal::mt($prp{$short}); } # ----------------------------------------------------------------- Assign Role @@ -3668,6 +3820,16 @@ sub assignrole { return 'refused'; } $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 { my $cwosec=$url; $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; @@ -3828,6 +3990,7 @@ sub modifyuser { } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } + &devalidate_cache_new('namescache',$uname.':'.$udom); &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. $last.', '.$gene.' by '. @@ -3968,7 +4131,9 @@ sub createcourse { return 'refused'; } # ------------------------------------------------------------------- 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'}; # ----------------------------------------------- Make sure that does not exist my $uhome=&homeserver($uname,$udom,'true'); @@ -4476,7 +4641,7 @@ sub get_userresdata { } #error 2 occurs when the .db doesn't exist if ($tmp!~/error: 2 /) { - &logthis("WARNING:". + &logthis("WARNING:". " Trying to get resource data for ". $uname." at ".$udom.": ". $tmp.""); @@ -4630,7 +4795,7 @@ sub EXT { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { if ($qualifier eq 'textremote') { - if (&mt('textual_remote_display') eq 'on') { + if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') { return 1; } else { return 0; @@ -5258,6 +5423,9 @@ sub symbread { if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { $targetfn = 'adm/wrapper/'.$thisfn; } + if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { + $targetfn=$1; + } if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_READER(),0640)) { $syval=$hash{$targetfn}; @@ -5371,8 +5539,37 @@ sub numval3 { 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 { - return '64bit4'; + return '64bit5'; } sub get_rand_alg { @@ -5412,11 +5609,15 @@ sub rndseed { if (!$username) { $username=$wusername } my $which=&get_rand_alg(); 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); } else { return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); } + } elsif ($which eq '64bit5') { + return &rndseed_64bit5($symb,$courseid,$domain,$username); } elsif ($which eq '64bit4') { return &rndseed_64bit4($symb,$courseid,$domain,$username); } elsif ($which eq '64bit3') { @@ -5539,6 +5740,12 @@ 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 { my ($symb,$courseid,$domain,$username)=@_; { @@ -5577,6 +5784,13 @@ 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 { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { @@ -5915,13 +6129,6 @@ sub thaw_unescape { return &unescape($value); } -sub mod_perl_version { - return 1; - if (defined($perlvar{'MODPERL2'})) { - return 2; - } -} - sub correct_line_ends { my ($result)=@_; $$result =~s/\r\n/\n/mg; @@ -5992,7 +6199,7 @@ BEGIN { # next if /^\#/; chomp; 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_arg_def{$domain}=$def_auth_arg; $domaindescription{$domain}=$domain_description; @@ -6000,6 +6207,7 @@ BEGIN { $domain_city{$domain}=$city; $domain_longi{$domain}=$longi; $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 ".$domaindescription{$domain} ); @@ -6026,7 +6234,7 @@ BEGIN { } close($config); # FIXME: dev server don't want this, production servers _do_ want this - #&get_iphost(); + &get_iphost(); } sub get_iphost { @@ -6120,7 +6328,7 @@ $processmarker='_'.time.'_'.$perlvar{'lo $dumpcount=0; &logtouch(); -&logthis('INFO: Read configuration'); +&logthis('INFO: Read configuration'); $readit=1; { use integer;