version 1.555, 2004/10/27 18:23:08
|
version 1.579, 2004/12/17 22:40:09
|
Line 38 use vars
|
Line 38 use vars
|
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache |
%userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
|
|
use IO::Socket; |
use IO::Socket; |
use GDBM_File; |
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
use HTML::LCParser; |
use HTML::LCParser; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
use Apache::loncoursedata; |
|
use Apache::lonlocal; |
use Apache::lonlocal; |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); |
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 ); |
my $readit; |
my $readit; |
my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 10; # Or some such value. |
Line 1189 sub ssi_body {
|
Line 1188 sub ssi_body {
|
my ($filelink,%form)=@_; |
my ($filelink,%form)=@_; |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
&ssi($filelink,%form)); |
&ssi($filelink,%form)); |
$output=~ |
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs; |
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
|
$output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
return $output; |
return $output; |
Line 1408 sub finishuserfileupload {
|
Line 1406 sub finishuserfileupload {
|
} |
} |
# Save the file |
# Save the file |
{ |
{ |
#&Apache::lonnet::logthis("Saving to $filepath $file"); |
open(FH,'>'.$filepath.'/'.$file); |
open(my $fh,'>'.$filepath.'/'.$file); |
print FH $ENV{'form.'.$formname}; |
print $fh $ENV{'form.'.$formname}; |
close(FH); |
close($fh); |
|
} |
} |
# Notify homeserver to grep it |
# Notify homeserver to grep it |
# |
# |
|
&Apache::lonnet::logthis("fetching ".$path.$file); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
# |
# |
Line 1492 sub flushcourselogs {
|
Line 1490 sub flushcourselogs {
|
if ($courseidbuffer{$coursehombuf{$crsid}}) { |
if ($courseidbuffer{$coursehombuf{$crsid}}) { |
$courseidbuffer{$coursehombuf{$crsid}}.='&'. |
$courseidbuffer{$coursehombuf{$crsid}}.='&'. |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
'='.&escape($courseinstcodebuf{$crsid}); |
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); |
} else { |
} else { |
$courseidbuffer{$coursehombuf{$crsid}}= |
$courseidbuffer{$coursehombuf{$crsid}}= |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
'='.&escape($courseinstcodebuf{$crsid}); |
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); |
} |
} |
} |
} |
# |
# |
# Write course id database (reverse lookup) to homeserver of courses |
# Write course id database (reverse lookup) to homeserver of courses |
Line 1572 sub courselog {
|
Line 1570 sub courselog {
|
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
$courseinstcodebuf{$ENV{'request.course.id'}}= |
$courseinstcodebuf{$ENV{'request.course.id'}}= |
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; |
|
$courseownerbuf{$ENV{'request.course.id'}}= |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'}; |
if (defined $courselogs{$ENV{'request.course.id'}}) { |
if (defined $courselogs{$ENV{'request.course.id'}}) { |
$courselogs{$ENV{'request.course.id'}}.='&'.$what; |
$courselogs{$ENV{'request.course.id'}}.='&'.$what; |
} else { |
} else { |
Line 1644 sub get_course_adv_roles {
|
Line 1644 sub get_course_adv_roles {
|
if (($tend) && ($tend<$now)) { next; } |
if (($tend) && ($tend<$now)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
my ($role,$username,$domain,$section)=split(/\:/,$_); |
|
if ($username eq '' || $domain eq '') { next; } |
if ((&privileged($username,$domain)) && |
if ((&privileged($username,$domain)) && |
(!$nothide{$username.':'.$domain})) { next; } |
(!$nothide{$username.':'.$domain})) { next; } |
my $key=&plaintext($role); |
my $key=&plaintext($role); |
Line 1715 sub courseidput {
|
Line 1716 sub courseidput {
|
} |
} |
|
|
sub courseiddump { |
sub courseiddump { |
my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_; |
my %returnhash=(); |
my %returnhash=(); |
unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
Line 1723 sub courseiddump {
|
Line 1724 sub courseiddump {
|
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
foreach ( |
foreach ( |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
$sincefilter.':'.&escape($descfilter), |
$sincefilter.':'.&escape($descfilter).':'. |
|
&escape($instcodefilter).':'.&escape($ownerfilter), |
$tryserver))) { |
$tryserver))) { |
my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
if (($key) && ($value)) { |
if (($key) && ($value)) { |
Line 2389 sub rolesinit {
|
Line 2391 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 %thesepriv=(); |
|
my $now=time; |
my $now=time; |
my $userroles="user.login.time=$now\n"; |
my $userroles="user.login.time=$now\n"; |
my $thesestr; |
|
|
|
if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
foreach (split(/&/,$rolesdump)) { |
foreach (split(/&/,$rolesdump)) { |
Line 2400 sub rolesinit {
|
Line 2400 sub rolesinit {
|
my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
$area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
my ($trole,$tend,$tstart)=split(/_/,$role); |
my ($trole,$tend,$tstart)=split(/_/,$role); |
$userroles.='user.role.'.$trole.'.'.$area.'='. |
$userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); |
$tstart.'.'.$tend."\n"; |
if (($tend!=0) && ($tend<$now)) { $trole=''; } |
# log the associated role with the area |
if (($tstart!=0) && ($tstart>$now)) { $trole=''; } |
&userrolelog($trole,$username,$domain,$area,$tstart,$tend); |
|
if ($tend!=0) { |
|
if ($tend<$now) { |
|
$trole=''; |
|
} |
|
} |
|
if ($tstart!=0) { |
|
if ($tstart>$now) { |
|
$trole=''; |
|
} |
|
} |
|
if (($area ne '') && ($trole ne '')) { |
if (($area ne '') && ($trole ne '')) { |
my $spec=$trole.'.'.$area; |
my $spec=$trole.'.'.$area; |
my ($tdummy,$tdomain,$trest)=split(/\//,$area); |
my ($tdummy,$tdomain,$trest)=split(/\//,$area); |
if ($trole =~ /^cr\//) { |
if ($trole =~ /^cr\//) { |
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); |
my $homsvr=homeserver($rauthor,$rdomain); |
|
if ($hostname{$homsvr} ne '') { |
|
my ($rdummy,$roledef)= |
|
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
|
|
|
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
|
my ($syspriv,$dompriv,$coursepriv)= |
|
split(/\_/,$roledef); |
|
if (defined($syspriv)) { |
|
$allroles{'cm./'}.=':'.$syspriv; |
|
$allroles{$spec.'./'}.=':'.$syspriv; |
|
} |
|
if ($tdomain ne '') { |
|
if (defined($dompriv)) { |
|
$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; |
|
$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
|
} |
|
if ($trest ne '') { |
|
if (defined($coursepriv)) { |
|
$allroles{'cm.'.$area}.=':'.$coursepriv; |
|
$allroles{$spec.'.'.$area}.=':'.$coursepriv; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} else { |
} else { |
if (defined($pr{$trole.':s'})) { |
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
$allroles{'cm./'}.=':'.$pr{$trole.':s'}; |
|
$allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; |
|
} |
|
if ($tdomain ne '') { |
|
if (defined($pr{$trole.':d'})) { |
|
$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
|
$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
|
} |
|
if ($trest ne '') { |
|
if (defined($pr{$trole.':c'})) { |
|
$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; |
|
$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; |
|
} |
|
} |
|
} |
|
} |
} |
} |
} |
} |
} |
} |
} |
my $adv=0; |
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); |
my $author=0; |
|
foreach (keys %allroles) { |
|
%thesepriv=(); |
|
if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } |
|
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } |
|
foreach (split(/:/,$allroles{$_})) { |
|
if ($_ ne '') { |
|
my ($privilege,$restrictions)=split(/&/,$_); |
|
if ($restrictions eq '') { |
|
$thesepriv{$privilege}='F'; |
|
} else { |
|
if ($thesepriv{$privilege} ne 'F') { |
|
$thesepriv{$privilege}.=$restrictions; |
|
} |
|
} |
|
} |
|
} |
|
$thesestr=''; |
|
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } |
|
$userroles.='user.priv.'.$_.'='.$thesestr."\n"; |
|
} |
|
$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 2495 sub rolesinit {
|
Line 2422 sub rolesinit {
|
return $userroles; |
return $userroles; |
} |
} |
|
|
|
sub set_arearole { |
|
my ($trole,$area,$tstart,$tend,$domain,$username) = @_; |
|
# log the associated role with the area |
|
&userrolelog($trole,$username,$domain,$area,$tstart,$tend); |
|
return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n"; |
|
} |
|
|
|
sub custom_roleprivs { |
|
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; |
|
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
|
my $homsvr=homeserver($rauthor,$rdomain); |
|
if ($hostname{$homsvr} ne '') { |
|
my ($rdummy,$roledef)= |
|
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
|
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
|
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
|
if (defined($syspriv)) { |
|
$$allroles{'cm./'}.=':'.$syspriv; |
|
$$allroles{$spec.'./'}.=':'.$syspriv; |
|
} |
|
if ($tdomain ne '') { |
|
if (defined($dompriv)) { |
|
$$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; |
|
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
|
} |
|
if (($trest ne '') && (defined($coursepriv))) { |
|
$$allroles{'cm.'.$area}.=':'.$coursepriv; |
|
$$allroles{$spec.'.'.$area}.=':'.$coursepriv; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
sub standard_roleprivs { |
|
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_; |
|
if (defined($pr{$trole.':s'})) { |
|
$$allroles{'cm./'}.=':'.$pr{$trole.':s'}; |
|
$$allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; |
|
} |
|
if ($tdomain ne '') { |
|
if (defined($pr{$trole.':d'})) { |
|
$$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
|
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
|
} |
|
if (($trest ne '') && (defined($pr{$trole.':c'}))) { |
|
$$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; |
|
$$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; |
|
} |
|
} |
|
} |
|
|
|
sub set_userprivs { |
|
my ($userroles,$allroles) = @_; |
|
my $author=0; |
|
my $adv=0; |
|
foreach (keys %{$allroles}) { |
|
my %thesepriv=(); |
|
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } |
|
foreach (split(/:/,$$allroles{$_})) { |
|
if ($_ ne '') { |
|
my ($privilege,$restrictions)=split(/&/,$_); |
|
if ($restrictions eq '') { |
|
$thesepriv{$privilege}='F'; |
|
} elsif ($thesepriv{$privilege} ne 'F') { |
|
$thesepriv{$privilege}.=$restrictions; |
|
} |
|
if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
|
} |
|
} |
|
my $thesestr=''; |
|
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } |
|
$$userroles.='user.priv.'.$_.'='.$thesestr."\n"; |
|
} |
|
return ($author,$adv); |
|
} |
|
|
# --------------------------------------------------------------- get interface |
# --------------------------------------------------------------- get interface |
|
|
sub get { |
sub get { |
Line 2516 sub get {
|
Line 2521 sub get {
|
my %returnhash=(); |
my %returnhash=(); |
my $i=0; |
my $i=0; |
foreach (@$storearr) { |
foreach (@$storearr) { |
$returnhash{$_}=unescape($pairs[$i]); |
$returnhash{$_}=&thaw_unescape($pairs[$i]); |
$i++; |
$i++; |
} |
} |
return %returnhash; |
return %returnhash; |
Line 2555 sub dump {
|
Line 2560 sub dump {
|
my %returnhash=(); |
my %returnhash=(); |
foreach (@pairs) { |
foreach (@pairs) { |
my ($key,$value)=split(/=/,$_); |
my ($key,$value)=split(/=/,$_); |
$returnhash{unescape($key)}=unescape($value); |
$returnhash{unescape($key)}=&thaw_unescape($value); |
} |
} |
return %returnhash; |
return %returnhash; |
} |
} |
Line 2601 sub currentdump {
|
Line 2606 sub currentdump {
|
my ($key,$value)=split(/=/,$_); |
my ($key,$value)=split(/=/,$_); |
my ($symb,$param) = split(/:/,$key); |
my ($symb,$param) = split(/:/,$key); |
$returnhash{&unescape($symb)}->{&unescape($param)} = |
$returnhash{&unescape($symb)}->{&unescape($param)} = |
&unescape($value); |
&thaw_unescape($value); |
} |
} |
} |
} |
return %returnhash; |
return %returnhash; |
Line 2667 sub put {
|
Line 2672 sub put {
|
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
my $items=''; |
my $items=''; |
foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
$items.=&escape($_).'='.&escape($$storehash{$_}).'&'; |
$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
Line 2706 sub cput {
|
Line 2711 sub cput {
|
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
my $items=''; |
my $items=''; |
foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
$items.=escape($_).'='.escape($$storehash{$_}).'&'; |
$items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
return &critical("put:$udomain:$uname:$namespace:$items",$uhome); |
return &critical("put:$udomain:$uname:$namespace:$items",$uhome); |
Line 2729 sub eget {
|
Line 2734 sub eget {
|
my %returnhash=(); |
my %returnhash=(); |
my $i=0; |
my $i=0; |
foreach (@$storearr) { |
foreach (@$storearr) { |
$returnhash{$_}=unescape($pairs[$i]); |
$returnhash{$_}=&thaw_unescape($pairs[$i]); |
$i++; |
$i++; |
} |
} |
return %returnhash; |
return %returnhash; |
Line 2772 sub customaccess {
|
Line 2777 sub customaccess {
|
# ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
|
|
sub allowed { |
sub allowed { |
my ($priv,$uri)=@_; |
my ($priv,$uri,$symb)=@_; |
$uri=&deversion($uri); |
$uri=&deversion($uri); |
my $orguri=$uri; |
my $orguri=$uri; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
Line 3053 sub allowed {
|
Line 3058 sub allowed {
|
|
|
if ($thisallowed=~/X/) { |
if ($thisallowed=~/X/) { |
if ($ENV{'acc.randomout'}) { |
if ($ENV{'acc.randomout'}) { |
my $symb=&symbread($uri,1); |
if (!$symb) { $symb=&symbread($uri,1); } |
if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { |
if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { |
return ''; |
return ''; |
} |
} |
Line 3628 sub modify_student_enrollment {
|
Line 3633 sub modify_student_enrollment {
|
$gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); |
$gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); |
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
} |
} |
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, |
my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); |
$first,$middle); |
|
my $reply=cput('classlist', |
my $reply=cput('classlist', |
{"$uname:$udom" => |
{"$uname:$udom" => |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
Line 3646 sub modify_student_enrollment {
|
Line 3650 sub modify_student_enrollment {
|
return &assignrole($udom,$uname,$uurl,'st',$end,$start); |
return &assignrole($udom,$uname,$uurl,'st',$end,$start); |
} |
} |
|
|
|
sub format_name { |
|
my ($firstname,$middlename,$lastname,$generation,$first)=@_; |
|
my $name; |
|
if ($first ne 'lastname') { |
|
$name=$firstname.' '.$middlename.' '.$lastname.' '.$generation; |
|
} else { |
|
if ($lastname=~/\S/) { |
|
$name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename; |
|
$name=~s/\s+,/,/; |
|
} else { |
|
$name.= $firstname.' '.$middlename.' '.$generation; |
|
} |
|
} |
|
$name=~s/^\s+//; |
|
$name=~s/\s+$//; |
|
$name=~s/\s+/ /g; |
|
return $name; |
|
} |
|
|
# ------------------------------------------------- Write to course preferences |
# ------------------------------------------------- Write to course preferences |
|
|
sub writecoursepref { |
sub writecoursepref { |
Line 3668 sub writecoursepref {
|
Line 3691 sub writecoursepref {
|
# ---------------------------------------------------------- Make/modify course |
# ---------------------------------------------------------- Make/modify course |
|
|
sub createcourse { |
sub createcourse { |
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_; |
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; |
$url=&declutter($url); |
$url=&declutter($url); |
my $cid=''; |
my $cid=''; |
unless (&allowed('ccc',$udom)) { |
unless (&allowed('ccc',$udom)) { |
Line 3703 sub createcourse {
|
Line 3726 sub createcourse {
|
# ----------------------------------------------------------------- Course made |
# ----------------------------------------------------------------- Course made |
# log existence |
# log existence |
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). |
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). |
'='.&escape($inst_code),$uhome); |
':'.&escape($inst_code).':'.&escape($course_owner),$uhome); |
&flushcourselogs(); |
&flushcourselogs(); |
# set toplevel url |
# set toplevel url |
my $topurl=$url; |
my $topurl=$url; |
Line 3764 sub diskusage {
|
Line 3787 sub diskusage {
|
return $listing; |
return $listing; |
} |
} |
|
|
|
sub is_locked { |
|
my ($file_name, $domain, $user) = @_; |
|
my @check; |
|
my $is_locked; |
|
push @check, $file_name; |
|
my %locked = &Apache::lonnet::get('file_permissions',\@check, |
|
$ENV{'user.domain'},$ENV{'user.name'}); |
|
if (ref($locked{$file_name}) eq 'ARRAY') { |
|
$is_locked = 'true'; |
|
} else { |
|
$is_locked = 'false'; |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------- Mark as Read Only |
|
|
|
sub mark_as_readonly { |
|
my ($domain,$user,$files,$what) = @_; |
|
my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); |
|
foreach my $file (@{$files}) { |
|
push(@{$current_permissions{$file}},$what); |
|
} |
|
&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); |
|
return; |
|
} |
|
|
|
# ------------------------------------------------------------Save Selected Files |
|
|
|
sub save_selected_files { |
|
my ($user, $path, @files) = @_; |
|
my $filename = $user."savedfiles"; |
|
my @other_files = &files_not_in_path($user, $path); |
|
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
|
foreach my $file (@files) { |
|
print (OUT $ENV{'form.currentpath'}.$file."\n"); |
|
} |
|
foreach my $file (@other_files) { |
|
print (OUT $file."\n"); |
|
} |
|
close (OUT); |
|
return 'ok'; |
|
} |
|
|
|
sub clear_selected_files { |
|
my ($user) = @_; |
|
my $filename = $user."savedfiles"; |
|
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
|
print (OUT undef); |
|
close (OUT); |
|
return ("ok"); |
|
} |
|
|
|
sub files_in_path { |
|
my ($user, $path) = @_; |
|
my $filename = $user."savedfiles"; |
|
my %return_files; |
|
open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
|
while (my $line_in = <IN>) { |
|
chomp ($line_in); |
|
my @paths_and_file = split (m!/!, $line_in); |
|
my $file_part = pop (@paths_and_file); |
|
my $path_part = join ('/', @paths_and_file); |
|
$path_part.='/'; |
|
my $path_and_file = $path_part.$file_part; |
|
if ($path_part eq $path) { |
|
$return_files{$file_part}= 'selected'; |
|
} |
|
} |
|
close (IN); |
|
return (\%return_files); |
|
} |
|
|
|
# called in portfolio select mode, to show files selected NOT in current directory |
|
sub files_not_in_path { |
|
my ($user, $path) = @_; |
|
my $filename = $user."savedfiles"; |
|
my @return_files; |
|
my $path_part; |
|
open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
|
while (<IN>) { |
|
#ok, I know it's clunky, but I want it to work |
|
my @paths_and_file = split m!/!, $_; |
|
my $file_part = pop (@paths_and_file); |
|
chomp ($file_part); |
|
my $path_part = join ('/', @paths_and_file); |
|
$path_part .= '/'; |
|
my $path_and_file = $path_part.$file_part; |
|
if ($path_part ne $path) { |
|
push (@return_files, ($path_and_file)); |
|
} |
|
} |
|
close (OUT); |
|
return (@return_files); |
|
} |
|
|
|
#--------------------------------------------------------------Get Marked as Read Only |
|
|
|
sub get_marked_as_readonly { |
|
my ($domain,$user,$what) = @_; |
|
my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); |
|
my @readonly_files; |
|
while (my ($file_name,$value) = each(%current_permissions)) { |
|
if (ref($value) eq "ARRAY"){ |
|
foreach my $stored_what (@{$value}) { |
|
if ($stored_what eq $what) { |
|
push(@readonly_files, $file_name); |
|
} elsif (!defined($what)) { |
|
push(@readonly_files, $file_name); |
|
} |
|
} |
|
} |
|
} |
|
return @readonly_files; |
|
} |
|
#-----------------------------------------------------------Get Marked as Read Only Hash |
|
|
|
sub get_marked_as_readonly_hash { |
|
my ($domain,$user,$what) = @_; |
|
my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); |
|
my %readonly_files; |
|
while (my ($file_name,$value) = each(%current_permissions)) { |
|
if (ref($value) eq "ARRAY"){ |
|
foreach my $stored_what (@{$value}) { |
|
if ($stored_what eq $what) { |
|
$readonly_files{$file_name} = 'locked'; |
|
} elsif (!defined($what)) { |
|
$readonly_files{$file_name} = 'locked'; |
|
} |
|
} |
|
} |
|
} |
|
return %readonly_files; |
|
} |
|
# ------------------------------------------------------------ Unmark as Read Only |
|
|
|
sub unmark_as_readonly { |
|
# unmarks all files locked by $what |
|
# for portfolio submissions, $what contains $crsid and $symb |
|
my ($domain,$user,$what) = @_; |
|
my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); |
|
my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what); |
|
foreach my $file(@readonly_files){ |
|
my $current_locks = $current_permissions{$file}; |
|
my @new_locks; |
|
my @del_keys; |
|
if (ref($current_locks) eq "ARRAY"){ |
|
foreach my $locker (@{$current_locks}) { |
|
unless ($locker eq $what) { |
|
push(@new_locks, $what); |
|
} |
|
} |
|
if (@new_locks > 0) { |
|
$current_permissions{$file} = \@new_locks; |
|
} else { |
|
push(@del_keys, $file); |
|
&Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user); |
|
delete $current_permissions{$file}; |
|
} |
|
} |
|
} |
|
&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); |
|
return; |
|
} |
|
|
# ------------------------------------------------------------ Directory lister |
# ------------------------------------------------------------ Directory lister |
|
|
Line 4526 sub gettitle {
|
Line 4712 sub gettitle {
|
my $symb=&symbread($urlsymb); |
my $symb=&symbread($urlsymb); |
if ($symb) { |
if ($symb) { |
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
if (defined($cached)) { return $result; } |
if (defined($cached)) { |
|
return $result; |
|
} |
my ($map,$resid,$url)=&decode_symb($symb); |
my ($map,$resid,$url)=&decode_symb($symb); |
my $title=''; |
my $title=''; |
my %bighash; |
my %bighash; |
Line 4615 sub symbverify {
|
Line 4803 sub symbverify {
|
|
|
sub symbclean { |
sub symbclean { |
my $symb=shift; |
my $symb=shift; |
|
if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } |
# remove version from map |
# remove version from map |
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; |
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; |
|
|
Line 4636 sub encode_symb {
|
Line 4824 sub encode_symb {
|
} |
} |
|
|
sub decode_symb { |
sub decode_symb { |
my ($map,$resid,$url)=split(/\_\_\_/,shift); |
my $symb=shift; |
|
if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } |
|
my ($map,$resid,$url)=split(/___/,$symb); |
return (&fixversion($map),$resid,&fixversion($url)); |
return (&fixversion($map),$resid,&fixversion($url)); |
} |
} |
|
|
Line 4685 sub symbread {
|
Line 4875 sub symbread {
|
} |
} |
$thisfn=$ENV{'request.filename'}; |
$thisfn=$ENV{'request.filename'}; |
} |
} |
|
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
# is that filename actually a symb? Verify, clean, and return |
# is that filename actually a symb? Verify, clean, and return |
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
if (&symbverify($thisfn,$1)) { |
if (&symbverify($thisfn,$1)) { |
Line 4775 sub numval {
|
Line 4966 sub numval {
|
$txt=~tr/U-Z/0-5/; |
$txt=~tr/U-Z/0-5/; |
$txt=~tr/u-z/0-5/; |
$txt=~tr/u-z/0-5/; |
$txt=~s/\D//g; |
$txt=~s/\D//g; |
|
if ($_64bit) { if ($txt > 2**32) { return -1; } } |
return int($txt); |
return int($txt); |
} |
} |
|
|
Line 4790 sub numval2 {
|
Line 4982 sub numval2 {
|
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); |
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); |
my $total; |
my $total; |
foreach my $val (@txts) { $total+=$val; } |
foreach my $val (@txts) { $total+=$val; } |
|
if ($_64bit) { if ($total > 2**32) { return -1; } } |
return int($total); |
return int($total); |
} |
} |
|
|
|
sub numval3 { |
|
use integer; |
|
my $txt=shift; |
|
$txt=~tr/A-J/0-9/; |
|
$txt=~tr/a-j/0-9/; |
|
$txt=~tr/K-T/0-9/; |
|
$txt=~tr/k-t/0-9/; |
|
$txt=~tr/U-Z/0-5/; |
|
$txt=~tr/u-z/0-5/; |
|
$txt=~s/\D//g; |
|
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); |
|
my $total; |
|
foreach my $val (@txts) { $total+=$val; } |
|
if ($_64bit) { $total=(($total<<32)>>32); } |
|
return $total; |
|
} |
|
|
sub latest_rnd_algorithm_id { |
sub latest_rnd_algorithm_id { |
return '64bit3'; |
return '64bit4'; |
} |
} |
|
|
sub get_rand_alg { |
sub get_rand_alg { |
Line 4806 sub get_rand_alg {
|
Line 5016 sub get_rand_alg {
|
return &latest_rnd_algorithm_id(); |
return &latest_rnd_algorithm_id(); |
} |
} |
|
|
|
sub validCODE { |
|
my ($CODE)=@_; |
|
if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; } |
|
return 0; |
|
} |
|
|
sub getCODE { |
sub getCODE { |
if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } |
if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } |
if (defined($Apache::lonhomework::parsing_a_problem) && |
if (defined($Apache::lonhomework::parsing_a_problem) && |
defined($Apache::lonhomework::history{'resource.CODE'})) { |
&validCODE($Apache::lonhomework::history{'resource.CODE'})) { |
return $Apache::lonhomework::history{'resource.CODE'}; |
return $Apache::lonhomework::history{'resource.CODE'}; |
} |
} |
return undef; |
return undef; |
Line 4827 sub rndseed {
|
Line 5043 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())) { |
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
if ($which eq '64bit4') { |
|
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); |
|
} else { |
|
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
|
} |
|
} elsif ($which eq '64bit4') { |
|
return &rndseed_64bit4($symb,$courseid,$domain,$username); |
} elsif ($which eq '64bit3') { |
} elsif ($which eq '64bit3') { |
return &rndseed_64bit3($symb,$courseid,$domain,$username); |
return &rndseed_64bit3($symb,$courseid,$domain,$username); |
} elsif ($which eq '64bit2') { |
} elsif ($which eq '64bit2') { |
Line 4851 sub rndseed_32bit {
|
Line 5073 sub rndseed_32bit {
|
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
|
if ($_64bit) { $num=(($num<<32)>>32); } |
return $num; |
return $num; |
} |
} |
} |
} |
Line 4871 sub rndseed_64bit {
|
Line 5094 sub rndseed_64bit {
|
my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
|
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
|
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
return "$num1,$num2"; |
return "$num1,$num2"; |
} |
} |
} |
} |
Line 4914 sub rndseed_64bit3 {
|
Line 5139 sub rndseed_64bit3 {
|
my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
|
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
|
|
|
return "$num1:$num2"; |
|
} |
|
} |
|
|
|
sub rndseed_64bit4 { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
{ |
|
use integer; |
|
# strings need to be an even # of cahracters long, it it is odd the |
|
# last characters gets thrown away |
|
my $symbchck=unpack("%32S*",$symb.' ') << 21; |
|
my $symbseed=numval3($symb) << 10; |
|
my $namechck=unpack("%32S*",$username.' '); |
|
|
|
my $nameseed=numval3($username) << 21; |
|
my $domainseed=unpack("%32S*",$domain.' ') << 10; |
|
my $courseseed=unpack("%32S*",$courseid.' '); |
|
|
|
my $num1=$symbchck+$symbseed+$namechck; |
|
my $num2=$nameseed+$domainseed+$courseseed; |
|
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
|
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
|
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
|
|
return "$num1:$num2"; |
return "$num1:$num2"; |
} |
} |
} |
} |
Line 4932 sub rndseed_CODE_64bit {
|
Line 5183 sub rndseed_CODE_64bit {
|
my $num2=$CODEseed+$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
|
if ($_64bit) { $num1=(($num1<<32)>>32); } |
|
if ($_64bit) { $num2=(($num2<<32)>>32); } |
|
return "$num1:$num2"; |
|
} |
|
} |
|
|
|
sub rndseed_CODE_64bit4 { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
{ |
|
use integer; |
|
my $symbchck=unpack("%32S*",$symb.' ') << 16; |
|
my $symbseed=numval3($symb); |
|
my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; |
|
my $CODEseed=numval3(&getCODE()); |
|
my $courseseed=unpack("%32S*",$courseid.' '); |
|
my $num1=$symbseed+$CODEchck; |
|
my $num2=$CODEseed+$courseseed+$symbchck; |
|
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
|
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
|
if ($_64bit) { $num1=(($num1<<32)>>32); } |
|
if ($_64bit) { $num2=(($num2<<32)>>32); } |
return "$num1:$num2"; |
return "$num1:$num2"; |
} |
} |
} |
} |
Line 5220 sub current_machine_ids {
|
Line 5492 sub current_machine_ids {
|
|
|
sub declutter { |
sub declutter { |
my $thisfn=shift; |
my $thisfn=shift; |
|
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$thisfn=~s/^\///; |
$thisfn=~s/^\///; |
$thisfn=~s/^res\///; |
$thisfn=~s/^res\///; |
Line 5237 sub clutter {
|
Line 5510 sub clutter {
|
return $thisfn; |
return $thisfn; |
} |
} |
|
|
|
sub freeze_escape { |
|
my ($value)=@_; |
|
if (ref($value)) { |
|
$value=&nfreeze($value); |
|
return '__FROZEN__'.&escape($value); |
|
} |
|
return &escape($value); |
|
} |
|
|
# -------------------------------------------------------- Escape Special Chars |
# -------------------------------------------------------- Escape Special Chars |
|
|
sub escape { |
sub escape { |
Line 5253 sub unescape {
|
Line 5535 sub unescape {
|
return $str; |
return $str; |
} |
} |
|
|
|
sub thaw_unescape { |
|
my ($value)=@_; |
|
if ($value =~ /^__FROZEN__/) { |
|
substr($value,0,10,undef); |
|
$value=&unescape($value); |
|
return &thaw($value); |
|
} |
|
return &unescape($value); |
|
} |
|
|
sub mod_perl_version { |
sub mod_perl_version { |
if (defined($perlvar{'MODPERL2'})) { |
if (defined($perlvar{'MODPERL2'})) { |
return 2; |
return 2; |
Line 5433 $dumpcount=0;
|
Line 5725 $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; |
|
my $test=(2**32)+1; |
|
if ($test != 0) { $_64bit=1; } else { $_64bit=0; } |
|
&logthis(" Detected 64bit platform ($_64bit)"); |
|
} |
} |
} |
} |
} |
|
|