WARNING: ".
"Attempt to modify environment ".$_." to ".$newenv{$_}
@@ -301,7 +258,7 @@ sub appenv {
} else {
$ENV{$_}=$newenv{$_};
}
- } keys %newenv;
+ }
my $lockfh;
unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
@@ -383,9 +340,9 @@ sub delenv {
$fh->close();
return 'error: '.$!;
}
- map {
+ foreach (@oldenv) {
unless ($_=~/^$delthis/) { print $fh $_; }
- } @oldenv;
+ }
$fh->close();
}
return 'ok';
@@ -407,11 +364,85 @@ sub spareserver {
return $spareserver;
}
+# --------------------------------------------- Try to change a user's password
+
+sub changepass {
+ my ($uname,$udom,$currentpass,$newpass,$server)=@_;
+ $currentpass = &escape($currentpass);
+ $newpass = &escape($newpass);
+ my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
+ $server);
+ if (! $answer) {
+ &logthis("No reply on password change request to $server ".
+ "by $uname in domain $udom.");
+ } elsif ($answer =~ "^ok") {
+ &logthis("$uname in $udom successfully changed their password ".
+ "on $server.");
+ } elsif ($answer =~ "^pwchange_failure") {
+ &logthis("$uname in $udom was unable to change their password ".
+ "on $server. The action was blocked by either lcpasswd ".
+ "or pwchange");
+ } elsif ($answer =~ "^non_authorized") {
+ &logthis("$uname in $udom did not get their password correct when ".
+ "attempting to change it on $server.");
+ } elsif ($answer =~ "^auth_mode_error") {
+ &logthis("$uname in $udom attempted to change their password despite ".
+ "not being locally or internally authenticated on $server.");
+ } elsif ($answer =~ "^unknown_user") {
+ &logthis("$uname in $udom attempted to change their password ".
+ "on $server but were unable to because $server is not ".
+ "their home server.");
+ } elsif ($answer =~ "^refused") {
+ &logthis("$server refused to change $uname in $udom password because ".
+ "it was sent an unencrypted request to change the password.");
+ }
+ return $answer;
+}
+
+# ----------------------- Try to determine user's current authentication scheme
+
+sub queryauthenticate {
+ my ($uname,$udom)=@_;
+ if (($perlvar{'lonRole'} eq 'library') &&
+ ($udom eq $perlvar{'lonDefDomain'})) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",
+ $perlvar{'lonHostID'});
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+
+ my $tryserver;
+ foreach $tryserver (keys %libserv) {
+ if ($hostdom{$tryserver} eq $udom) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+ }
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+}
+
# --------- Try to authenticate user from domain's lib servers (first this one)
sub authenticate {
my ($uname,$upass,$udom)=@_;
$upass=escape($upass);
+ $uname=~s/\W//g;
if (($perlvar{'lonRole'} eq 'library') &&
($udom eq $perlvar{'lonDefDomain'})) {
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
@@ -451,18 +482,23 @@ sub authenticate {
sub homeserver {
my ($uname,$udom)=@_;
-
my $index="$uname:$udom";
- if ($homecache{$index}) { return "$homecache{$index}"; }
-
+ if ($homecache{$index}) {
+ return "$homecache{$index}";
+ }
my $tryserver;
foreach $tryserver (keys %libserv) {
+ next if (exists($badhomecache{$index}->{$tryserver}));
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {
- $homecache{$index}=$tryserver;
+ $homecache{$index}=$tryserver;
return $tryserver;
- }
+ } else {
+ $badhomecache{$index}->{$tryserver}=1;
+ }
+ } else {
+ $badhomecache{$index}->{$tryserver}=1;
}
}
return 'no_host';
@@ -500,9 +536,9 @@ sub idget {
sub idrget {
my ($udom,@unames)=@_;
my %returnhash=();
- map {
+ foreach (@unames) {
$returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
- } @unames;
+ }
return %returnhash;
}
@@ -511,7 +547,7 @@ sub idrget {
sub idput {
my ($udom,%ids)=@_;
my %servers=();
- map {
+ foreach (keys %ids) {
my $uhom=&homeserver($_,$udom);
if ($uhom ne 'no_host') {
my $id=&escape($ids{$_});
@@ -524,10 +560,10 @@ sub idput {
}
&critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
}
- } keys %ids;
- map {
+ }
+ foreach (keys %servers) {
&critical('idput:'.$udom.':'.$servers{$_},$_);
- } keys %servers;
+ }
}
# ------------------------------------- Find the section of student in a course
@@ -536,7 +572,8 @@ sub usection {
my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
- map {
+ foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
+ &homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);
$key=&unescape($key);
if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
@@ -553,8 +590,7 @@ sub usection {
}
unless ($notactive) { return $section; }
}
- } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
- &homeserver($unam,$udom)));
+ }
return '-1';
}
@@ -596,6 +632,7 @@ sub subscribe {
sub repcopy {
my $filename=shift;
$filename=~s/\/+/\//g;
+ if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
my $transname="$filename.in.transfer";
if ((-e $filename) || (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);
@@ -661,7 +698,7 @@ sub ssi {
if (%form) {
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
- $request->content(join '&', map { "$_=$form{$_}" } keys %form);
+ $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
} else {
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
}
@@ -683,12 +720,11 @@ sub log {
sub flushcourselogs {
&logthis('Flushing course log buffers');
- map {
+ foreach (keys %courselogs) {
my $crsid=$_;
- if (&reply('log:'.$ENV{'course.'.$crsid.'.domain'}.':'.
- $ENV{'course.'.$crsid.'.num'}.':'.
- &escape($courselogs{$crsid}),
- $ENV{'course.'.$crsid.'.home'}) eq 'ok') {
+ if (&reply('log:'.$coursedombuf{$crsid}.':'.
+ &escape($courselogs{$crsid}),
+ $coursehombuf{$crsid}) eq 'ok') {
delete $courselogs{$crsid};
} else {
&logthis('Failed to flush log buffer for '.$crsid);
@@ -698,13 +734,28 @@ sub flushcourselogs {
delete $courselogs{$crsid};
}
}
- } keys %courselogs;
+ }
+ &logthis('Flushing access logs');
+ foreach (keys %accesshash) {
+ my $entry=$_;
+ $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
+ my %temphash=($entry => $accesshash{$entry});
+ if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') {
+ delete $accesshash{$entry};
+ }
+ }
+ $dumpcount++;
}
sub courselog {
my $what=shift;
$what=time.':'.$what;
unless ($ENV{'request.course.id'}) { return ''; }
+ $coursedombuf{$ENV{'request.course.id'}}=
+ $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
+ $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
+ $coursehombuf{$ENV{'request.course.id'}}=
+ $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
if (defined $courselogs{$ENV{'request.course.id'}}) {
$courselogs{$ENV{'request.course.id'}}.='&'.$what;
} else {
@@ -719,16 +770,29 @@ sub courseacclog {
my $fnsymb=shift;
unless ($ENV{'request.course.id'}) { return ''; }
my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
- if ($what=~/(problem|exam|quiz|assess|survey|form)$/) {
- map {
+ if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {
+ $what.=':POST';
+ foreach (keys %ENV) {
if ($_=~/^form\.(.*)/) {
$what.=':'.$1.'='.$ENV{$_};
}
- } keys %ENV;
+ }
}
&courselog($what);
}
+sub countacc {
+ my $url=&declutter(shift);
+ unless ($ENV{'request.course.id'}) { return ''; }
+ $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
+ my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count';
+ if (defined($accesshash{$key})) {
+ $accesshash{$key}++;
+ } else {
+ $accesshash{$key}=1;
+ }
+}
+
# ----------------------------------------------------------- Check out an item
sub checkout {
@@ -855,30 +919,251 @@ sub devalidate {
}
}
+sub arrayref2str {
+ my ($arrayref) = @_;
+ my $result='_ARRAY_REF__';
+ foreach my $elem (@$arrayref) {
+ if (ref($elem) eq 'ARRAY') {
+ $result.=&escape(&arrayref2str($elem)).'&';
+ } elsif (ref($elem) eq 'HASH') {
+ $result.=&escape(&hashref2str($elem)).'&';
+ } elsif (ref($elem)) {
+ &logthis("Got a ref of ".(ref($elem))." skipping.");
+ } else {
+ $result.=&escape($elem).'&';
+ }
+ }
+ $result=~s/\&$//;
+ return $result;
+}
+
+sub hash2str {
+ my (%hash) = @_;
+ my $result=&hashref2str(\%hash);
+ $result=~s/^_HASH_REF__//;
+ return $result;
+}
+
+sub hashref2str {
+ my ($hashref)=@_;
+ my $result='_HASH_REF__';
+ foreach (keys(%$hashref)) {
+ if (ref($_) eq 'ARRAY') {
+ $result.=&escape(&arrayref2str($_)).'=';
+ } elsif (ref($_) eq 'HASH') {
+ $result.=&escape(&hashref2str($_)).'=';
+ } elsif (ref($_)) {
+ &logthis("Got a ref of ".(ref($_))." skipping.");
+ } else {
+ $result.=&escape($_).'=';
+ }
+
+ if (ref($$hashref{$_}) eq 'ARRAY') {
+ $result.=&escape(&arrayref2str($$hashref{$_})).'&';
+ } elsif (ref($$hashref{$_}) eq 'HASH') {
+ $result.=&escape(&hashref2str($$hashref{$_})).'&';
+ } elsif (ref($$hashref{$_})) {
+ &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");
+ } else {
+ $result.=&escape($$hashref{$_}).'&';
+ }
+ }
+ $result=~s/\&$//;
+ return $result;
+}
+
+sub str2hash {
+ my ($string) = @_;
+ my %returnhash;
+ foreach (split(/\&/,$string)) {
+ my ($name,$value)=split(/\=/,$_);
+ $name=&unescape($name);
+ $value=&unescape($value);
+ if ($value =~ /^_HASH_REF__/) {
+ $value =~ s/^_HASH_REF__//;
+ my %hash=&str2hash($value);
+ $value=\%hash;
+ } elsif ($value =~ /^_ARRAY_REF__/) {
+ $value =~ s/^_ARRAY_REF__//;
+ my @array=&str2array($value);
+ $value=\@array;
+ }
+ $returnhash{$name}=$value;
+ }
+ return (%returnhash);
+}
+
+sub str2array {
+ my ($string) = @_;
+ my @returnarray;
+ foreach my $value (split(/\&/,$string)) {
+ $value=&unescape($value);
+ if ($value =~ /^_HASH_REF__/) {
+ $value =~ s/^_HASH_REF__//;
+ my %hash=&str2hash($value);
+ $value=\%hash;
+ } elsif ($value =~ /^_ARRAY_REF__/) {
+ $value =~ s/^_ARRAY_REF__//;
+ my @array=&str2array($value);
+ $value=\@array;
+ }
+ push(@returnarray,$value);
+ }
+ return (@returnarray);
+}
+
+# -------------------------------------------------------------------Temp Store
+
+sub tmpreset {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my %hash;
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ foreach my $key (keys %hash) {
+ if ($key=~ /:$symb/) {
+ delete($hash{$key});
+ }
+ }
+ }
+}
+
+sub tmpstore {
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) {
+ # I don't think we would ever want to store this for a course.
+ # it seems this will only be used if we don't have a course.
+ #$namespace=$ENV{'request.course.id'};
+ #if (!$namespace) {
+ $namespace=$ENV{'request.state'};
+ #}
+ }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+#FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $now=time;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ $hash{"version:$symb"}++;
+ my $version=$hash{"version:$symb"};
+ my $allkeys='';
+ foreach my $key (keys(%$storehash)) {
+ $allkeys.=$key.':';
+ $hash{"$version:$symb:$key"}=$$storehash{$key};
+ }
+ $hash{"$version:$symb:timestamp"}=$now;
+ $allkeys.='timestamp';
+ $hash{"$version:keys:$symb"}=$allkeys;
+ if (untie(%hash)) {
+ return 'ok';
+ } else {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+}
+
+# -----------------------------------------------------------------Temp Restore
+
+sub tmprestore {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+
+ my %returnhash;
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_READER,0640)) {
+ my $version=$hash{"version:$symb"};
+ $returnhash{'version'}=$version;
+ my $scope;
+ for ($scope=1;$scope<=$version;$scope++) {
+ my $vkeys=$hash{"$scope:keys:$symb"};
+ my @keys=split(/:/,$vkeys);
+ my $key;
+ $returnhash{"$scope:keys"}=$vkeys;
+ foreach $key (@keys) {
+ $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
+ $returnhash{"$key"}=$hash{"$scope:$symb:$key"};
+ }
+ }
+ if (!(untie(%hash))) {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+ return %returnhash;
+}
+
# ----------------------------------------------------------------------- Store
sub store {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
+ $symb=&symbclean($symb);
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
&devalidate($symb);
$symb=escape($symb);
- if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$namespace) {
+ unless ($namespace=$ENV{'request.course.id'}) {
+ return '';
+ }
+ }
if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }
if (!$home) { $home=$ENV{'user.home'}; }
my $namevalue='';
- map {
+ foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
- } keys %$storehash;
+ }
$namevalue=~s/\&$//;
+ &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
}
@@ -888,26 +1173,31 @@ sub cstore {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
+ $symb=&symbclean($symb);
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
&devalidate($symb);
$symb=escape($symb);
- if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$namespace) {
+ unless ($namespace=$ENV{'request.course.id'}) {
+ return '';
+ }
+ }
if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }
if (!$home) { $home=$ENV{'user.home'}; }
my $namevalue='';
- map {
+ foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
- } keys %$storehash;
+ }
$namevalue=~s/\&$//;
- return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
+ &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
+ return critical
+ ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
}
# --------------------------------------------------------------------- Restore
@@ -916,31 +1206,33 @@ sub restore {
my ($symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) {
unless ($symb=escape(&symbread())) { return ''; }
} else {
- $symb=&escape($symb);
+ $symb=&escape(&symbclean($symb));
+ }
+ if (!$namespace) {
+ unless ($namespace=$ENV{'request.course.id'}) {
+ return '';
+ }
}
- if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }
if (!$home) { $home=$ENV{'user.home'}; }
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
my %returnhash=();
- map {
+ foreach (split(/\&/,$answer)) {
my ($name,$value)=split(/\=/,$_);
$returnhash{&unescape($name)}=&unescape($value);
- } split(/\&/,$answer);
+ }
my $version;
for ($version=1;$version<=$returnhash{'version'};$version++) {
- map {
+ foreach (split(/\:/,$returnhash{$version.':keys'})) {
$returnhash{$_}=$returnhash{$version.':'.$_};
- } split(/\:/,$returnhash{$version.':keys'});
+ }
}
return %returnhash;
}
@@ -991,7 +1283,7 @@ sub rolesinit {
my $thesestr;
if ($rolesdump ne '') {
- map {
+ foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef\&/) {
my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;
@@ -1047,14 +1339,14 @@ sub rolesinit {
}
}
}
- } split(/&/,$rolesdump);
+ }
my $adv=0;
my $author=0;
- map {
+ foreach (keys %allroles) {
%thesepriv=();
if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
- map {
+ foreach (split(/:/,$allroles{$_})) {
if ($_ ne '') {
my ($privilege,$restrictions)=split(/&/,$_);
if ($restrictions eq '') {
@@ -1065,11 +1357,11 @@ sub rolesinit {
}
}
}
- } split(/:/,$allroles{$_});
+ }
$thesestr='';
- map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
+ foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
$userroles.='user.priv.'.$_.'='.$thesestr."\n";
- } keys %allroles;
+ }
$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";
$ENV{'user.adv'}=$adv;
@@ -1082,9 +1374,9 @@ sub rolesinit {
sub get {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- map {
+ foreach (@$storearr) {
$items.=escape($_).'&';
- } @$storearr;
+ }
$items=~s/\&$//;
if (!$udomain) { $udomain=$ENV{'user.domain'}; }
if (!$uname) { $uname=$ENV{'user.name'}; }
@@ -1094,10 +1386,10 @@ sub get {
my @pairs=split(/\&/,$rep);
my %returnhash=();
my $i=0;
- map {
+ foreach (@$storearr) {
$returnhash{$_}=unescape($pairs[$i]);
$i++;
- } @$storearr;
+ }
return %returnhash;
}
@@ -1106,9 +1398,9 @@ sub get {
sub del {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- map {
+ foreach (@$storearr) {
$items.=escape($_).'&';
- } @$storearr;
+ }
$items=~s/\&$//;
if (!$udomain) { $udomain=$ENV{'user.domain'}; }
if (!$uname) { $uname=$ENV{'user.name'}; }
@@ -1120,17 +1412,22 @@ sub del {
# -------------------------------------------------------------- dump interface
sub dump {
- my ($namespace,$udomain,$uname)=@_;
+ my ($namespace,$udomain,$uname,$regexp)=@_;
if (!$udomain) { $udomain=$ENV{'user.domain'}; }
if (!$uname) { $uname=$ENV{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
- my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
+ if ($regexp) {
+ $regexp=&escape($regexp);
+ } else {
+ $regexp='.';
+ }
+ my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
- map {
+ foreach (@pairs) {
my ($key,$value)=split(/=/,$_);
$returnhash{unescape($key)}=unescape($value);
- } @pairs;
+ }
return %returnhash;
}
@@ -1142,9 +1439,9 @@ sub put {
if (!$uname) { $uname=$ENV{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- map {
+ foreach (keys %$storehash) {
$items.=&escape($_).'='.&escape($$storehash{$_}).'&';
- } keys %$storehash;
+ }
$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
@@ -1157,9 +1454,9 @@ sub cput {
if (!$uname) { $uname=$ENV{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- map {
+ foreach (keys %$storehash) {
$items.=escape($_).'='.escape($$storehash{$_}).'&';
- } keys %$storehash;
+ }
$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
}
@@ -1169,9 +1466,9 @@ sub cput {
sub eget {
my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
- map {
+ foreach (@$storearr) {
$items.=escape($_).'&';
- } @$storearr;
+ }
$items=~s/\&$//;
if (!$udomain) { $udomain=$ENV{'user.domain'}; }
if (!$uname) { $uname=$ENV{'user.name'}; }
@@ -1180,10 +1477,10 @@ sub eget {
my @pairs=split(/\&/,$rep);
my %returnhash=();
my $i=0;
- map {
+ foreach (@$storearr) {
$returnhash{$_}=unescape($pairs[$i]);
$i++;
- } @$storearr;
+ }
return %returnhash;
}
@@ -1242,7 +1539,7 @@ sub allowed {
# If this is generating or modifying users, exit with special codes
- if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
+ if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
return $thisallowed;
}
#
@@ -1276,7 +1573,7 @@ sub allowed {
my $refuri=$ENV{'httpref.'.$orguri};
unless ($refuri) {
- map {
+ foreach (keys %ENV) {
if ($_=~/^httpref\..*\*/) {
my $pattern=$_;
$pattern=~s/^httpref\.\/res\///;
@@ -1286,7 +1583,7 @@ sub allowed {
$refuri=$ENV{$_};
}
}
- } keys %ENV;
+ }
}
if ($refuri) {
$refuri=&declutter($refuri);
@@ -1395,7 +1692,7 @@ sub allowed {
if ($thisallowed=~/C/) {
my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
- =~/\,$rolecode\,/) {
+ =~/$rolecode/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$ENV{'request.course.id'});
@@ -1442,7 +1739,7 @@ sub allowed {
sub definerole {
if (allowed('mcr','/')) {
my ($rolename,$sysrole,$domrole,$courole)=@_;
- map {
+ foreach (split('/',$sysrole)) {
my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/$crole\&/) {
@@ -1450,8 +1747,8 @@ sub definerole {
return "refused:s:$crole&$cqual";
}
}
- } split('/',$sysrole);
- map {
+ }
+ foreach (split('/',$domrole)) {
my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/$crole\&/) {
@@ -1459,8 +1756,8 @@ sub definerole {
return "refused:d:$crole&$cqual";
}
}
- } split('/',$domrole);
- map {
+ }
+ foreach (split('/',$courole)) {
my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/$crole\&/) {
@@ -1468,7 +1765,7 @@ sub definerole {
return "refused:c:$crole&$cqual";
}
}
- } split('/',$courole);
+ }
my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
"$ENV{'user.domain'}:$ENV{'user.name'}:".
"rolesdef_$rolename=".
@@ -1483,7 +1780,6 @@ sub definerole {
sub metadata_query {
my ($query,$custom,$customshow)=@_;
- # need to put in a library server loop here and return a hash
my %rhash;
for my $server (keys %libserv) {
unless ($custom or $customshow) {
@@ -1507,20 +1803,6 @@ sub plaintext {
return $prp{$short};
}
-# ------------------------------------------------------------------ Plain Text
-
-sub fileembstyle {
- my $ending=shift;
- return $fe{$ending};
-}
-
-# ------------------------------------------------------------ Description Text
-
-sub filedescription {
- my $ending=shift;
- return $fd{$ending};
-}
-
# ----------------------------------------------------------------- Assign Role
sub assignrole {
@@ -1558,22 +1840,55 @@ sub assignrole {
return &reply($command,&homeserver($uname,$udom));
}
-# --------------------------------------------------------------- Modify a user
+# -------------------------------------------------- Modify user authentication
+# Overrides without validation
+
+sub modifyuserauth {
+ my ($udom,$uname,$umode,$upass)=@_;
+ my $uhome=&homeserver($uname,$udom);
+ unless (&allowed('mau',$udom)) { return 'refused'; }
+ &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
+ $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
+ &escape($upass),$uhome);
+ &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
+ 'Authentication changed for '.$udom.', '.$uname.', '.$umode.
+ '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
+ &log($udom,,$uname,$uhome,
+ 'Authentication changed by '.$ENV{'user.domain'}.', '.
+ $ENV{'user.name'}.', '.$umode.
+ '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
+ unless ($reply eq 'ok') {
+ &logthis('Authentication mode error: '.$reply);
+ return 'error: '.$reply;
+ }
+ return 'ok';
+}
+# --------------------------------------------------------------- Modify a user
sub modifyuser {
- my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
+ my ($udom, $uname, $uid,
+ $umode, $upass, $first,
+ $middle, $last, $gene,
+ $forceid, $desiredhome)=@_;
+ $udom=~s/\W//g;
+ $uname=~s/\W//g;
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.' by '.
- $ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ $last.', '.$gene.'(forceid: '.$forceid.')'.
+ (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
+ ' desiredhome not specified').
+ ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
my $uhome=&homeserver($uname,$udom);
# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') && ($umode) && ($upass)) {
my $unhome='';
- if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
+ if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
+ $unhome = $desiredhome;
+ } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
$unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
- } else {
+ } else { # load balancing routine for determining $unhome
my $tryserver;
my $loadm=10000000;
foreach $tryserver (keys %libserv) {
@@ -1587,7 +1902,8 @@ sub modifyuser {
}
}
if (($unhome eq '') || ($unhome eq 'no_host')) {
- return 'error: find home';
+ return 'error: unable to find a home server for '.$uname.
+ ' in domain '.$udom;
}
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$unhome);
@@ -1598,12 +1914,13 @@ sub modifyuser {
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
return 'error: verify home';
}
- }
+ } # End of creation of new user
# ---------------------------------------------------------------------- Add ID
if ($uid) {
$uid=~tr/A-Z/a-z/;
my %uidhash=&idrget($udom,$uname);
- if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {
+ if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)
+ && (!$forceid)) {
unless ($uid eq $uidhash{$uname}) {
return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
}
@@ -1615,6 +1932,7 @@ sub modifyuser {
my %names=&get('environment',
['firstname','middlename','lastname','generation'],
$udom,$uname);
+ if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }
if ($first) { $names{'firstname'} = $first; }
if ($middle) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }
@@ -1632,14 +1950,15 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
- $end,$start)=@_;
+ $end,$start,$forceid,$desiredhome)=@_;
my $cid='';
unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';
}
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser
- ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);
+ ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
+ $desiredhome);
unless ($reply eq 'ok') { return $reply; }
my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
@@ -1675,9 +1994,9 @@ sub writecoursepref {
return 'error: no such course';
}
my $cstring='';
- map {
+ foreach (keys %prefs) {
$cstring.=escape($_).'='.escape($prefs{$_}).'&';
- } keys %prefs;
+ }
$cstring=~s/\&$//;
return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
}
@@ -1766,17 +2085,17 @@ sub dirlist {
$tryserver);
if (($listing ne 'no_such_dir') && ($listing ne 'empty')
&& ($listing ne 'con_lost')) {
- map {
+ foreach (split(/:/,$listing)) {
my ($entry,@stat)=split(/&/,$_);
$allusers{$entry}=1;
- } split(/:/,$listing);
+ }
}
}
}
my $alluserstr='';
- map {
+ foreach (sort keys %allusers) {
$alluserstr.=$_.'&user:';
- } sort keys %allusers;
+ }
$alluserstr=~s/:$//;
return split(/:/,$alluserstr);
}
@@ -1787,9 +2106,9 @@ sub dirlist {
$alldom{$hostdom{$tryserver}}=1;
}
my $alldomstr='';
- map {
+ foreach (sort keys %alldom) {
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
- } sort keys %alldom;
+ }
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
}
@@ -1810,18 +2129,18 @@ sub condval {
my $condidx=shift;
my $result=0;
my $allpathcond='';
- map {
+ foreach (split(/\|/,$condidx)) {
if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
$allpathcond.=
'('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
}
- } split(/\|/,$condidx);
+ }
$allpathcond=~s/\|$//;
if ($ENV{'request.course.id'}) {
if ($allpathcond) {
my $operand='|';
my @stack;
- map {
+ foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
if ($_ eq '(') {
push @stack,($operand,$result)
} elsif ($_ eq ')') {
@@ -1839,19 +2158,62 @@ sub condval {
$result=$result>$new?$new:$result;
} else {
$result=$result>$new?$result:$new;
- }
+ }
}
- } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g);
+ }
}
}
return $result;
}
+# --------------------------------------------------- Course Resourcedata Query
+
+sub courseresdata {
+ my ($coursenum,$coursedomain,@which)=@_;
+ my $coursehom=&homeserver($coursenum,$coursedomain);
+ my $hashid=$coursenum.':'.$coursedomain;
+ unless (defined($courseresdatacache{$hashid.'.time'})) {
+ unless (time-$courseresdatacache{$hashid.'.time'}<300) {
+ my $coursehom=&homeserver($coursenum,$coursedomain);
+ if ($coursehom) {
+ my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum.
+ ':resourcedata:.',$coursehom);
+ unless ($dumpreply=~/^error\:/) {
+ $courseresdatacache{$hashid.'.time'}=time;
+ $courseresdatacache{$hashid}=$dumpreply;
+ }
+ }
+ }
+ }
+ my @pairs=split(/\&/,$courseresdatacache{$hashid});
+ my %returnhash=();
+ foreach (@pairs) {
+ my ($key,$value)=split(/=/,$_);
+ $returnhash{unescape($key)}=unescape($value);
+ }
+ my $item;
+ foreach $item (@which) {
+ if ($returnhash{$item}) { return $returnhash{$item}; }
+ }
+ return '';
+}
+
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm)=@_;
+ my ($varname,$symbparm,$udom,$uname)=@_;
+
unless ($varname) { return ''; }
+
+ #get real user name/domain, courseid and symb
+ my $courseid;
+ if (!($uname && $udom)) {
+ (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
+ if (!$symbparm) { $symbparm=$cursymb; }
+ } else {
+ $courseid=$ENV{'request.course.id'};
+ }
+
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;
if ($therest[0]) {
@@ -1866,19 +2228,28 @@ sub EXT {
if ($realm eq 'user') {
# --------------------------------------------------------------- user.resource
if ($space eq 'resource') {
- my %restored=&restore();
+ my %restored=&restore(undef,undef,$udom,$uname);
return $restored{$qualifierrest};
# ----------------------------------------------------------------- user.access
} elsif ($space eq 'access') {
+ # FIXME - not supporting calls for a specific user
return &allowed($qualifier,$rest);
# ------------------------------------------ user.preferences, user.environment
} elsif (($space eq 'preferences') || ($space eq 'environment')) {
- return $ENV{join('.',('environment',$qualifierrest))};
+ if (($uname eq $ENV{'user.name'}) &&
+ ($udom eq $ENV{'user.domain'})) {
+ return $ENV{join('.',('environment',$qualifierrest))};
+ } else {
+ my %returnhash=&userenvironment($udom,$uname,$qualifierrest);
+ return $returnhash{$qualifierrest};
+ }
# ----------------------------------------------------------------- user.course
} elsif ($space eq 'course') {
+ # FIXME - not supporting calls for a specific user
return $ENV{join('.',('request.course',$qualifier))};
# ------------------------------------------------------------------- user.role
} elsif ($space eq 'role') {
+ # FIXME - not supporting calls for a specific user
my ($role,$where)=split(/\./,$ENV{'request.role'});
if ($qualifier eq 'value') {
return $role;
@@ -1887,10 +2258,10 @@ sub EXT {
}
# ----------------------------------------------------------------- user.domain
} elsif ($space eq 'domain') {
- return $ENV{'user.domain'};
+ return $udom;
# ------------------------------------------------------------------- user.name
} elsif ($space eq 'name') {
- return $ENV{'user.name'};
+ return $uname;
# ---------------------------------------------------- Any other user namespace
} else {
my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
@@ -1907,123 +2278,112 @@ sub EXT {
}
} elsif ($realm eq 'course') {
# ---------------------------------------------------------- course.description
- return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
- $spacequalifierrest};
+ return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {
- if ($ENV{'request.course.id'}) {
+
+ if ($courseid eq $ENV{'request.course.id'}) {
+
+ #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
+
# ----------------------------------------------------- Cascading lookup scheme
- my $symbp;
- if ($symbparm) {
- $symbp=$symbparm;
- } else {
- $symbp=&symbread();
- }
- my $mapp=(split(/\_\_\_/,$symbp))[0];
-
- my $symbparm=$symbp.'.'.$spacequalifierrest;
- my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
-
- my $seclevel=
- $ENV{'request.course.id'}.'.['.
- $ENV{'request.course.sec'}.'].'.$spacequalifierrest;
- my $seclevelr=
- $ENV{'request.course.id'}.'.['.
- $ENV{'request.course.sec'}.'].'.$symbparm;
- my $seclevelm=
- $ENV{'request.course.id'}.'.['.
- $ENV{'request.course.sec'}.'].'.$mapparm;
-
- my $courselevel=
- $ENV{'request.course.id'}.'.'.$spacequalifierrest;
- my $courselevelr=
- $ENV{'request.course.id'}.'.'.$symbparm;
- my $courselevelm=
- $ENV{'request.course.id'}.'.'.$mapparm;
+ if (!$symbparm) { $symbparm=&symbread(); }
+ my $symbp=$symbparm;
+ my $mapp=(split(/\_\_\_/,$symbp))[0];
+
+ my $symbparm=$symbp.'.'.$spacequalifierrest;
+ my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
+
+ my $section;
+ if (($ENV{'user.name'} eq $uname) &&
+ ($ENV{'user.domain'} eq $udom)) {
+ $section={'request.course.sec'};
+ } else {
+ $section=&usection($udom,$uname,$courseid);
+ }
-# ----------------------------------------------------------- first, check user
- my %resourcedata=get('resourcedata',
- [$courselevelr,$courselevelm,$courselevel]);
- if (($resourcedata{$courselevelr}!~/^error\:/) &&
- ($resourcedata{$courselevelr}!~/^con_lost/)) {
-
- if ($resourcedata{$courselevelr}) {
- return $resourcedata{$courselevelr}; }
- if ($resourcedata{$courselevelm}) {
- return $resourcedata{$courselevelm}; }
- if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
+ my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
+ my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
+ my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
+
+ my $courselevel=$courseid.'.'.$spacequalifierrest;
+ my $courselevelr=$courseid.'.'.$symbparm;
+ my $courselevelm=$courseid.'.'.$mapparm;
- } else {
- if ($resourcedata{$courselevelr}!~/No such file/) {
- &logthis("WARNING:".
- " Trying to get resource data for ".$ENV{'user.name'}." at "
- .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
- "");
- }
- }
+# ----------------------------------------------------------- first, check user
+ my %resourcedata=&get('resourcedata',
+ [$courselevelr,$courselevelm,$courselevel],
+ $udom,$uname);
+ if (($resourcedata{$courselevelr}!~/^error\:/) &&
+ ($resourcedata{$courselevelr}!~/^con_lost/)) {
+
+ if ($resourcedata{$courselevelr}) {
+ return $resourcedata{$courselevelr}; }
+ if ($resourcedata{$courselevelm}) {
+ return $resourcedata{$courselevelm}; }
+ if ($resourcedata{$courselevel}) {
+ return $resourcedata{$courselevel}; }
+ } else {
+ if ($resourcedata{$courselevelr}!~/No such file/) {
+ &logthis("WARNING:".
+ " Trying to get resource data for ".
+ $uname." at ".$udom.": ".
+ $resourcedata{$courselevelr}."");
+ }
+ }
# -------------------------------------------------------- second, check course
- my $reply=&reply('get:'.
- $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
- $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
- ':resourcedata:'.
- &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
- &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
- $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
- if ($reply!~/^error\:/) {
- map {
- if ($_) { return &unescape($_); }
- } split(/\&/,$reply);
- }
- if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
- &logthis("WARNING:".
- " Getting ".$reply." asking for ".$varname." for ".
- $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
- ' at '.
- $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
- ' from '.
- $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
- "");
- }
+ my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
+ $ENV{'course.'.$courseid.'.domain'},
+ ($seclevelr,$seclevelm,$seclevel,
+ $courselevelr,$courselevelm,
+ $courselevel));
+ if ($coursereply) { return $coursereply; }
+
# ------------------------------------------------------ third, check map parms
- my %parmhash=();
- my $thisparm='';
- if (tie(%parmhash,'GDBM_File',
- $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
- $thisparm=$parmhash{$symbparm};
- untie(%parmhash);
- }
- if ($thisparm) { return $thisparm; }
- }
-
+ my %parmhash=();
+ my $thisparm='';
+ if (tie(%parmhash,'GDBM_File',
+ $ENV{'request.course.fn'}.'_parms.db',
+ &GDBM_READER,0640)) {
+ $thisparm=$parmhash{$symbparm};
+ untie(%parmhash);
+ }
+ if ($thisparm) { return $thisparm; }
+ }
# --------------------------------------------- last, look in resource metadata
- $spacequalifierrest=~s/\./\_/;
- my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
- if ($metadata) { return $metadata; }
- $metadata=&metadata($ENV{'request.filename'},
- 'parameter_'.$spacequalifierrest);
- if ($metadata) { return $metadata; }
+ $spacequalifierrest=~s/\./\_/;
+ my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
+ if ($metadata) { return $metadata; }
+ $metadata=&metadata($ENV{'request.filename'},
+ 'parameter_'.$spacequalifierrest);
+ if ($metadata) { return $metadata; }
# ------------------------------------------------------------------ Cascade up
-
- unless ($space eq '0') {
- my ($part,$id)=split(/(\.|\_)/,$space);
- if ($id) {
- my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
- $symbparm);
- if ($partgeneral) { return $partgeneral; }
- } else {
- my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
- $symbparm);
- if ($resourcegeneral) { return $resourcegeneral; }
- }
- }
+ unless ($space eq '0') {
+ my ($part,$id)=split(/\_/,$space);
+ if ($id) {
+ my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+ $symbparm,$udom,$uname);
+ if ($partgeneral) { return $partgeneral; }
+ } else {
+ my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
+ $symbparm,$udom,$uname);
+ if ($resourcegeneral) { return $resourcegeneral; }
+ }
+ }
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
- return $ENV{'environment.'.$spacequalifierrest};
+ if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) {
+ return $ENV{'environment.'.$spacequalifierrest};
+ } else {
+ my %returnhash=&userenvironment($udom,$uname,
+ $spacequalifierrest);
+ return $returnhash{$spacequalifierrest};
+ }
} elsif ($realm eq 'system') {
# ----------------------------------------------------------------- system.time
if ($space eq 'time') {
@@ -2036,41 +2396,59 @@ sub EXT {
# ---------------------------------------------------------------- Get metadata
sub metadata {
- my ($uri,$what)=@_;
+ my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
my $filename=$uri;
$uri=~s/\.meta$//;
- unless ($metacache{$uri.':keys'}) {
+#
+# Is the metadata already cached?
+# Look at timestamp of caching
+# Everything is cached by the main uri, libraries are never directly cached
+#
+ unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
+#
+# Is this a recursive call for a library?
+#
+ if ($liburi) {
+ $liburi=&declutter($liburi);
+ $filename=$liburi;
+ }
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
- my $parser=HTML::TokeParser->new(\$metastring);
+ my $parser=HTML::LCParser->new(\$metastring);
my $token;
undef %metathesekeys;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
if (defined($token->[2]->{'package'})) {
+#
+# This is a package - get package info
+#
my $package=$token->[2]->{'package'};
my $keyroot='';
- if (defined($token->[2]->{'part'})) {
- $keyroot.='_'.$token->[2]->{'part'};
+ if ($prefix) {
+ $keyroot.='_'.$prefix;
+ } else {
+ if (defined($token->[2]->{'part'})) {
+ $keyroot.='_'.$token->[2]->{'part'};
+ }
}
if (defined($token->[2]->{'id'})) {
- $keyroot.='.'.$token->[2]->{'id'};
+ $keyroot.='_'.$token->[2]->{'id'};
}
if ($metacache{$uri.':packages'}) {
$metacache{$uri.':packages'}.=','.$package.$keyroot;
} else {
$metacache{$uri.':packages'}=$package.$keyroot;
}
- map {
+ foreach (keys %packagetab) {
if ($_=~/^$package\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);
my $value=$packagetab{$_};
my $part=$keyroot;
$part=~s/^\_//;
- $part=~s/\./\_/g;
if ($subp eq 'display') {
$value.=' [Part: '.$part.']';
}
@@ -2082,32 +2460,66 @@ sub metadata {
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;
}
}
- } keys %packagetab;
+ }
} else {
- my $entry=$token->[1];
- my $unikey=$entry;
- if (defined($token->[2]->{'part'})) {
- $unikey.='_'.$token->[2]->{'part'};
+#
+# This is not a package - some other kind of start tag
+#
+ my $entry=$token->[1];
+ my $unikey;
+ if ($entry eq 'import') {
+ $unikey='';
+ } else {
+ $unikey=$entry;
+ }
+ if ($prefix) {
+ $unikey.=$prefix;
+ } else {
+ if (defined($token->[2]->{'part'})) {
+ $unikey.='_'.$token->[2]->{'part'};
+ }
}
if (defined($token->[2]->{'id'})) {
- $unikey.='.'.$token->[2]->{'id'};
+ $unikey.='_'.$token->[2]->{'id'};
}
+
+ if ($entry eq 'import') {
+#
+# Importing a library here
+#
+ if (defined($depthcount)) { $depthcount++; } else
+ { $depthcount=0; }
+ if ($depthcount<20) {
+ foreach (split(/\,/,&metadata($uri,'keys',
+ $parser->get_text('/import'),$unikey,
+ $depthcount))) {
+ $metathesekeys{$_}=1;
+ }
+ }
+ } else {
+
if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};
}
$metathesekeys{$unikey}=1;
- map {
+ foreach (@{$token->[3]}) {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
- } @{$token->[3]};
+ }
unless (
- $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
+ $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))
) { $metacache{$uri.':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};
}
- }
+# end of not-a-package not-a-library import
+ }
+# end of not-a-package start tag
+ }
+# the next is the end of "start tag"
}
}
$metacache{$uri.':keys'}=join(',',keys %metathesekeys);
+ $metacache{$uri.':cachedtimestamp'}=time;
+# this is the end of "was not already recently cached
}
return $metacache{$uri.':'.$what};
}
@@ -2121,9 +2533,9 @@ sub symblist {
if (($ENV{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT,0640)) {
- map {
+ foreach (keys %newhash) {
$hash{declutter($_)}=$mapname.'___'.$newhash{$_};
- } keys %newhash;
+ }
if (untie(%hash)) {
return 'ok';
}
@@ -2132,11 +2544,63 @@ sub symblist {
return 'error';
}
+# --------------------------------------------------------------- Verify a symb
+
+sub symbverify {
+ my ($symb,$thisfn)=@_;
+ $thisfn=&declutter($thisfn);
+# direct jump to resource in page or to a sequence - will construct own symbs
+ if ($thisfn=~/\.(page|sequence)$/) { return 1; }
+# check URL part
+ my ($map,$resid,$url)=split(/\_\_\_/,$symb);
+ unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
+
+ $symb=&symbclean($symb);
+
+ my %bighash;
+ my $okay=0;
+ if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
+ &GDBM_READER,0640)) {
+ my $ids=$bighash{'ids_/res/'.$thisfn};
+ unless ($ids) {
+ $ids=$bighash{'ids_/'.$thisfn};
+ }
+ if ($ids) {
+# ------------------------------------------------------------------- Has ID(s)
+ foreach (split(/\,/,$ids)) {
+ my ($mapid,$resid)=split(/\./,$_);
+ if (
+ &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
+ eq $symb) {
+ $okay=1;
+ }
+ }
+ }
+ untie(%bighash);
+ }
+ return $okay;
+}
+
+# --------------------------------------------------------------- Clean-up symb
+
+sub symbclean {
+ my $symb=shift;
+
+# remove version from map
+ $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
+
+# remove version from URL
+ $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
+
+ return $symb;
+}
+
# ------------------------------------------------------ Return symb list entry
sub symbread {
my $thisfn=shift;
unless ($thisfn) {
+ if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
$thisfn=$ENV{'request.filename'};
}
$thisfn=declutter($thisfn);
@@ -2177,7 +2641,7 @@ sub symbread {
} else {
# ------------------------------------------ There is more than one possibility
my $realpossible=0;
- map {
+ foreach (@possibilities) {
my $file=$bighash{'src_'.$_};
if (&allowed('bre',$file)) {
my ($mapid,$resid)=split(/\./,$_);
@@ -2187,7 +2651,7 @@ sub symbread {
'___'.$resid;
}
}
- } @possibilities;
+ }
if ($realpossible!=1) { $syval=''; }
}
}
@@ -2195,7 +2659,7 @@ sub symbread {
}
}
if ($syval) {
- return $syval.'___'.$thisfn;
+ return &symbclean($syval.'___'.$thisfn);
}
}
&appenv('request.ambiguous' => $thisfn);
@@ -2296,7 +2760,7 @@ sub filelocation {
sub hreflocation {
my ($dir,$file)=@_;
- unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {
+ unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
my $finalpath=filelocation($dir,$file);
$finalpath=~s/^\/home\/httpd\/html//;
return $finalpath;
@@ -2333,14 +2797,44 @@ sub unescape {
# ================================================================ Main Program
-sub BEGIN {
-unless ($readit) {
-# ------------------------------------------------------------ Read access.conf
+sub goodbye {
+ &logthis("Starting Shut down");
+ &flushcourselogs();
+ &logthis("Shutting down");
+}
+
+BEGIN {
+# ---------------------------------- Read loncapa_apache.conf and loncapa.conf
+# (eventually access.conf will become deprecated)
+ unless ($readit) {
+
+{
+ my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
+
+ while (my $configline=<$config>) {
+ if ($configline =~ /^[^\#]*PerlSetVar/) {
+ my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
+ chomp($varvalue);
+ $perlvar{$varname}=$varvalue;
+ }
+ }
+}
+{
+ my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");
+
+ while (my $configline=<$config>) {
+ if ($configline =~ /^[^\#]*PerlSetVar/) {
+ my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
+ chomp($varvalue);
+ $perlvar{$varname}=$varvalue;
+ }
+ }
+}
{
- my $config=Apache::File->new("/etc/httpd/conf/access.conf");
+ my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
while (my $configline=<$config>) {
- if ($configline =~ /PerlSetVar/) {
+ if ($configline =~ /^[^\#]*PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);
$perlvar{$varname}=$varvalue;
@@ -2414,25 +2908,425 @@ unless ($readit) {
}
}
-# ------------------------------------------------------------- Read file types
-{
- my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
-
- while (my $configline=<$config>) {
- chomp($configline);
- my ($ending,$emb,@descr)=split(/\s+/,$configline);
- if ($descr[0] ne '') {
- $fe{$ending}=$emb;
- $fd{$ending}=join(' ',@descr);
- }
- }
-}
-
%metacache=();
-$readit='done';
+$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'};
+$dumpcount=0;
+
&logtouch();
&logthis('INFO: Read configuration');
+$readit=1;
}
}
+
1;
+__END__
+
+=head1 NAME
+
+Apache::lonnet - TCP networking package
+
+=head1 SYNOPSIS
+
+Invoked by other LON-CAPA modules.
+
+ &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
+
+=head1 INTRODUCTION
+
+This module provides subroutines which interact with the
+lonc/lond (TCP) network layer of LON-CAPA.
+
+This is part of the LearningOnline Network with CAPA project
+described at http://www.lon-capa.org.
+
+=head1 HANDLER SUBROUTINE
+
+There is no handler routine for this module.
+
+=head1 OTHER SUBROUTINES
+
+=over 4
+
+=item *
+
+logtouch() : make sure the logfile, lonnet.log, exists
+
+=item *
+
+logthis() : append message to lonnet.log
+
+=item *
+
+logperm() : append a permanent message to lonnet.perm.log
+
+=item *
+
+subreply() : non-critical communication, called by &reply
+
+=item *
+
+reply() : makes two attempts to pass message; logs refusals and rejections
+
+=item *
+
+reconlonc() : tries to reconnect lonc client processes.
+
+=item *
+
+critical() : passes a critical message to another server; if cannot get
+through then place message in connection buffer
+
+=item *
+
+appenv(%hash) : read in current user environment, append new environment
+values to make new user environment
+
+=item *
+
+delenv($varname) : read in current user environment, remove all values
+beginning with $varname, write new user environment (note: flock is used
+to prevent conflicting shared read/writes with file)
+
+=item *
+
+spareserver() : find server with least workload from spare.tab
+
+=item *
+
+queryauthenticate($uname,$udom) : try to determine user's current
+authentication scheme
+
+=item *
+
+authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib
+servers (first use the current one)
+
+=item *
+
+homeserver($uname,$udom) : find the homebase for a user from domain's lib
+servers
+
+=item *
+
+idget($udom,@ids) : find the usernames behind a list of IDs (returns hash:
+id=>name,id=>name)
+
+=item *
+
+idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:
+name=>id,name=>id)
+
+=item *
+
+idput($udom,%ids) : store away a list of names and associated IDs
+
+=item *
+
+usection($domain,$user,$courseid) : output of section name/number or '' for
+"not in course" and '-1' for "no section"
+
+=item *
+
+userenvironment($domain,$user,$what) : puts out any environment parameter
+for a user
+
+=item *
+
+subscribe($fname) : subscribe to a resource, return URL if possible
+
+=item *
+
+repcopy($filename) : replicate file
+
+=item *
+
+ssi($url,%hash) : server side include, does a complete request cycle on url to
+localhost, posts hash
+
+=item *
+
+log($domain,$name,$home,$message) : write to permanent log for user; use
+critical subroutine
+
+=item *
+
+flushcourselogs() : flush (save) buffer logs and access logs
+
+=item *
+
+courselog($what) : save message for course in hash
+
+=item *
+
+courseacclog($what) : save message for course using &courselog(). Perform
+special processing for specific resource types (problems, exams, quizzes, etc).
+
+=item *
+
+countacc($url) : count the number of accesses to a given URL
+
+=item *
+
+sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item
+
+=item *
+
+sub checkin($token) : check in an item
+
+=item *
+
+sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
+
+=item *
+
+devalidate($symb) : devalidate spreadsheets
+
+=item *
+
+hash2str(%hash) : convert a hash into a string complete with escaping and '='
+and '&' separators, supports elements that are arrayrefs and hashrefs
+
+=item *
+
+hashref2str($hashref) : convert a hashref into a string complete with
+escaping and '=' and '&' separators, supports elements that are
+arrayrefs and hashrefs
+
+=item *
+
+arrayref2str($arrayref) : convert an arrayref into a string complete
+with escaping and '&' separators, supports elements that are arrayrefs
+and hashrefs
+
+=item *
+
+str2hash($string) : convert string to hash using unescaping and
+splitting on '=' and '&', supports elements that are arrayrefs and
+hashrefs
+
+=item *
+
+str2array($string) : convert string to hash using unescaping and
+splitting on '&', supports elements that are arrayrefs and hashrefs
+
+=item *
+
+tmpreset($symb,$namespace,$domain,$stuname) : temporary storage
+
+=item *
+
+tmprestore($symb,$namespace,$domain,$stuname) : temporary restore
+
+=item *
+
+store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently
+for this url; hashref needs to be given and should be a \%hashname; the
+remaining args aren't required and if they aren't passed or are '' they will
+be derived from the ENV
+
+=item *
+
+cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but
+uses critical subroutine
+
+=item *
+
+restore($symb,$namespace,$domain,$stuname) : returns hash for this symb;
+all args are optional
+
+=item *
+
+coursedescription($courseid) : course description
+
+=item *
+
+rolesinit($domain,$username,$authhost) : get user privileges
+
+=item *
+
+get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
+reference filled in from namesp ($udomain and $uname are optional)
+
+=item *
+
+del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from
+namesp ($udomain and $uname are optional)
+
+=item *
+
+dump($namespace,$udomain,$uname,$regexp) :
+dumps the complete (or key matching regexp) namespace into a hash
+($udomain, $uname and $regexp are optional)
+
+=item *
+
+put($namespace,$storehash,$udomain,$uname) : stores hash in namesp
+($udomain and $uname are optional)
+
+=item *
+
+cput($namespace,$storehash,$udomain,$uname) : critical put
+($udomain and $uname are optional)
+
+=item *
+
+eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
+reference filled in from namesp (encrypts the return communication)
+($udomain and $uname are optional)
+
+=item *
+
+allowed($priv,$uri) : check for a user privilege; returns codes for allowed
+actions
+ F: full access
+ U,I,K: authentication modes (cxx only)
+ '': forbidden
+ 1: user needs to choose course
+ 2: browse allowed
+
+=item *
+
+definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
+role rolename set privileges in format of lonTabs/roles.tab for system, domain,
+and course level
+
+=item *
+
+metadata_query($query,$custom,$customshow) : make a metadata query against the
+network of library servers; returns file handle of where SQL and regex results
+will be stored for query
+
+=item *
+
+plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
+explanation of a user role term
+
+=item *
+
+assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
+user for the level given by URL. Optional start and end dates (leave empty
+string or zero for "no date")
+
+=item *
+
+modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
+
+=item *
+
+modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :
+modify user
+
+=item *
+
+modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
+$end,$start) : modify student
+
+=item *
+
+writecoursepref($courseid,%prefs) : write preferences for a course
+
+=item *
+
+createcourse($udom,$description,$url) : make/modify course
+
+=item *
+
+assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
+custom role; give a custom role to a user for the level given by URL. Specify
+name and domain of role author, and role name
+
+=item *
+
+revokerole($udom,$uname,$url,$role) : revoke a role for url
+
+=item *
+
+revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
+
+=item *
+
+dirlist($uri) : return directory list based on URI
+
+=item *
+
+directcondval($number) : get current value of a condition; reads from a state
+string
+
+=item *
+
+condval($condidx) : value of condition index based on state
+
+=item *
+
+EXT($varname,$symbparm) : value of a variable
+
+=item *
+
+metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the
+metadata entry for a file; entry='keys', returns a comma separated list of keys
+
+=item *
+
+symblist($mapname,%newhash) : update symbolic storage links
+
+=item *
+
+symbread($filename) : return symbolic list entry (filename argument optional);
+returns the data handle
+
+=item *
+
+numval($salt) : return random seed value (addend for rndseed)
+
+=item *
+
+rndseed($symb,$courseid,$domain,$username) : create a random sum; returns
+a random seed, all arguments are optional, if they aren't sent it uses the
+environment to derive them. Note: if symb isn't sent and it can't get one
+from &symbread it will use the current time as its return value
+
+=item *
+
+ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
+unfakeable, receipt
+
+=item *
+
+receipt() : API to ireceipt working off of ENV values; given out to users
+
+=item *
+
+getfile($file) : serves up a file, returns the contents of a file or -1;
+replicates and subscribes to the file
+
+=item *
+
+filelocation($dir,$file) : returns file system location of a file based on URI;
+meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob)
+
+=item *
+
+hreflocation($dir,$file) : returns file system location or a URL; same as
+filelocation except for hrefs
+
+=item *
+
+declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
+
+=item *
+
+escape() : unpack non-word characters into CGI-compatible hex codes
+
+=item *
+
+unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
+
+=item *
+
+goodbye() : flush course logs and log shutting down; it is called in srm.conf
+as a PerlChildExitHandler
+
+=back
+
+=cut
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.