|
version 1.674, 2005/11/01 15:07:29
|
version 1.686, 2005/12/19 21:03:53
|
|
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 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 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 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 3023 sub allowed {
|
Line 3069 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 3115 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 3146 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/|)) { |
|
Line 3652 sub auto_instcode_format {
|
Line 3704 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 3674 sub assignrole {
|
Line 3817 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 3834 sub modifyuser {
|
Line 3987 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 4638 sub EXT {
|
Line 4792 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 4655 sub EXT {
|
Line 4809 sub EXT {
|
| return $env{'course.'.$courseid.'.'.$spacequalifierrest}; |
return $env{'course.'.$courseid.'.'.$spacequalifierrest}; |
| } elsif ($realm eq 'resource') { |
} elsif ($realm eq 'resource') { |
| |
|
| my $section; |
my ($section,$group); |
| |
my @groups = (); |
| 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(); } |
| } |
} |
|
Line 4675 sub EXT {
|
Line 4830 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=split(/:/,$env{'request.course.groups'}); |
| |
if (@groups > 0) { |
| |
@groups = sort(@groups); |
| |
$group = $groups[0]; |
| |
} |
| } 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 = split(/:/,$grouplist); |
| |
@groups = sort(@groups); |
| |
$group = $groups[0]; |
| |
} |
| } |
} |
| |
|
| |
my $grplevel=$courseid.'.['.$group.'].'.$spacequalifierrest; |
| |
my $grplevelr=$courseid.'.['.$group.'].'.$symbparm; |
| |
my $grplevelm=$courseid.'.['.$group.'].'.$mapparm; |
| |
|
| my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
| my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; |
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; |
| my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; |
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; |
|
Line 4700 sub EXT {
|
Line 4870 sub EXT {
|
| if (defined($userreply)) { return $userreply; } |
if (defined($userreply)) { return $userreply; } |
| |
|
| # ------------------------------------------------ second, check some of course |
# ------------------------------------------------ second, check some of course |
| |
my $coursereply; |
| |
if (defined($group)) { |
| |
$coursereply = &resdata($env{'course.'.$courseid.'.num'}, |
| |
$env{'course.'.$courseid.'.domain'}, |
| |
'course', |
| |
($grplevelr,$grplevelm,$grplevel, |
| |
$courselevelr)); |
| |
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 5379 sub numval3 {
|
Line 5558 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 5420 sub rndseed {
|
Line 5628 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 5547 sub rndseed_64bit4 {
|
Line 5759 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 5585 sub rndseed_CODE_64bit4 {
|
Line 5803 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 5923 sub thaw_unescape {
|
Line 6148 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 6000 BEGIN {
|
Line 6218 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 6008 BEGIN {
|
Line 6226 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} ); |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl