version 1.674, 2005/11/01 15:07:29
|
version 1.678, 2005/11/15 21:35:02
|
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 2574 sub rolesinit {
|
Line 2575 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 2593 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 2608 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 2658 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 2689 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 = (); |
|
my %groups_checked = (); |
|
if (keys(%{$allgroups}) > 0) { |
|
foreach my $role (keys %{$allroles}) { |
|
my ($trole,$area); |
|
if ($role =~ m|^(\w+)\.(/\w+/\w+)|) { |
|
$trole = $1; |
|
$area = $2; |
|
unless ($groups_checked{$area}) { |
|
$groups_checked{$area} = 1; |
|
if (exists($$allgroups{$area})) { |
|
foreach my $group (keys(%{$$allgroups{$area}})) { |
|
my $spec = $trole.'.'.$area; |
|
$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 3067 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 3113 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 3144 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 3656 sub auto_instcode_format {
|
Line 3706 sub auto_instcode_format {
|
|
|
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 3724 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 4638 sub EXT {
|
Line 4698 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 5379 sub numval3 {
|
Line 5439 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 5509 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 5640 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 5684 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 6029 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; |