--- loncom/lonnet/perl/lonnet.pm 1999/12/22 17:18:04 1.7 +++ loncom/lonnet/perl/lonnet.pm 2000/09/06 14:25:17 1.30 @@ -1,15 +1,66 @@ # The LearningOnline Network # TCP networking package +# +# Functions for use by content handlers: +# +# plaintext(short) : plain text explanation of short term +# fileembstyle(ext) : embed style in page for file extension +# filedescription(ext) : descriptor text for file extension +# allowed(short,url) : 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 +# definerole(rolename,sys,dom,cou) : define a custom role rolename +# set priviledges in format of lonTabs/roles.tab for +# system, domain and course level, +# assignrole(udom,uname,url,role,end,start) : 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") +# assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a +# custom role to a user for the level given by url. +# Specify name and domain of role author, and role name +# revokerole (udom,uname,url,role) : Revoke a role for url +# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role +# appenv(hash) : adds hash to session environment +# store(hash) : stores hash permanently for this url +# restore : returns hash for this url +# eget(namesp,array) : returns hash with keys from array filled in from namesp +# get(namesp,array) : returns hash with keys from array filled in from namesp +# del(namesp,array) : deletes keys out of arry from namesp +# put(namesp,hash) : stores hash in namesp +# dump(namesp) : dumps the complete namespace into a hash +# ssi(url,hash) : does a complete request cycle on url to localhost, posts +# hash +# repcopy(filename) : replicate file +# dirlist(url) : gets a directory listing +# condval(index) : value of condition index based on state +# varval(name) : value of a variable +# refreshstate() : refresh the state information string +# # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, -# 11/8,11/16,11/18,11/22,11/23,12/22 Gerd Kortemeyer +# 11/8,11/16,11/18,11/22,11/23,12/22, +# 01/06,01/13,02/24,02/28,02/29, +# 03/01,03/02,03/06,03/07,03/13, +# 04/05,05/29,05/31,06/01, +# 06/05,06/26 Gerd Kortemeyer +# 06/26 Ben Tyszka +# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer +# 08/14 Ben Tyszka +# 08/22,08/28,08/31,09/01,09/02,09/04,09/05 Gerd Kortemeyer package Apache::lonnet; use strict; use Apache::File; -use vars qw(%perlvar %hostname %homecache %spareid %hostdom %libserv $readit); +use LWP::UserAgent(); +use HTTP::Headers; +use vars +qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit); use IO::Socket; +use Apache::Constants qw(:common :http); # --------------------------------------------------------------------- Logging @@ -43,8 +94,8 @@ sub subreply { or return "con_lost"; print $client "$cmd\n"; my $answer=<$client>; - chomp($answer); if (!$answer) { $answer="con_lost"; } + chomp($answer); return $answer; } @@ -52,6 +103,11 @@ sub reply { my ($cmd,$server)=@_; my $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } + if (($answer=~/^error:/) || ($answer=~/^refused/) || + ($answer=~/^rejected/)) { + &logthis("WARNING:". + " $cmd to $server returned $answer"); + } return $answer; } @@ -72,16 +128,20 @@ sub reconlonc { &logthis("$peerfile still not there, give it another try"); sleep 5; if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, giving up"); + &logthis( + "WARNING: $peerfile still not there, giving up"); } else { - &logthis("lonc at pid $loncpid not responding, giving up"); + &logthis( + "WARNING:". + " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } # ------------------------------------------------------ Critical communication + sub critical { my ($cmd,$server)=@_; my $answer=reply($cmd,$server); @@ -114,11 +174,13 @@ sub critical { } chomp($wcmd); if ($wcmd eq $cmd) { - &logthis("Connection buffer $dfilename: $cmd"); + &logthis("WARNING: ". + "Connection buffer $dfilename: $cmd"); &logperm("D:$server:$cmd"); return 'con_delayed'; } else { - &logthis("CRITICAL CONNECTION FAILED: $server $cmd"); + &logthis("CRITICAL:" + ." Critical connection failed: $server $cmd"); &logperm("F:$server:$cmd"); return 'con_failed'; } @@ -141,8 +203,12 @@ sub appenv { } for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); - my ($name,$value)=split(/=/,$oldenv[$i]); - $newenv{$name}=$value; + if ($oldenv[$i] ne '') { + my ($name,$value)=split(/=/,$oldenv[$i]); + unless (defined($newenv{$name})) { + $newenv{$name}=$value; + } + } } { my $fh; @@ -158,6 +224,7 @@ sub appenv { } # ------------------------------ Find server with least workload from spare.tab + sub spareserver { my $tryserver; my $spareserver=''; @@ -173,31 +240,47 @@ sub spareserver { } # --------- Try to authenticate user from domain's lib servers (first this one) + sub authenticate { my ($uname,$upass,$udom)=@_; - + $upass=escape($upass); if (($perlvar{'lonRole'} eq 'library') && ($udom eq $perlvar{'lonDefDomain'})) { my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { return $perlvar{'lonHostID'}; } - if ($answer eq 'non_authorized') { return 'no_host'; } + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by local server"); + return $perlvar{'lonHostID'}; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by local server"); + return 'no_host'; + } } } my $tryserver; foreach $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("enc:auth:$udom:$uname:$upass",$tryserver); + my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { return $tryserver; } + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by $tryserver"); + return $tryserver; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by $tryserver"); + return 'no_host'; + } } } - } + } + &logthis("User $uname at $udom could not be authenticated"); return 'no_host'; } # ---------------------- Find the homebase for a user from domain's lib servers + sub homeserver { my ($uname,$udom)=@_; @@ -218,14 +301,13 @@ sub homeserver { } # ----------------------------- Subscribe to a resource, return URL if possible + sub subscribe { my $fname=shift; - &logthis($fname); my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); my $home=homeserver($uname,$udom); - &logthis("$home $udom $uname"); if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { return 'not_found'; } @@ -233,6 +315,636 @@ sub subscribe { return $answer; } +# -------------------------------------------------------------- Replicate file + +sub repcopy { + my $filename=shift; + $filename=~s/\/+/\//g; + my $transname="$filename.in.transfer"; + if ((-e $filename) || (-e $transname)) { return OK; } + my $remoteurl=subscribe($filename); + if ($remoteurl eq 'con_lost') { + &logthis("Subscribe returned con_lost: $filename"); + return HTTP_SERVICE_UNAVAILABLE; + } elsif ($remoteurl eq 'not_found') { + &logthis("Subscribe returned not_found: $filename"); + return HTTP_NOT_FOUND; + } elsif ($remoteurl eq 'rejected') { + &logthis("Subscribe returned rejected: $filename"); + return FORBIDDEN; + } elsif ($remoteurl eq 'directory') { + return OK; + } else { + my @parts=split(/\//,$filename); + my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; + if ($path ne "$perlvar{'lonDocRoot'}/res") { + &logthis("Malconfiguration for replication: $filename"); + return HTTP_BAD_REQUEST; + } + my $count; + for ($count=5;$count<$#parts;$count++) { + $path.="/$parts[$count]"; + if ((-e $path)!=1) { + mkdir($path,0777); + } + } + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"$remoteurl"); + my $response=$ua->request($request,$transname); + if ($response->is_error()) { + unlink($transname); + my $message=$response->status_line; + &logthis("WARNING:" + ." LWP get: $message: $filename"); + return HTTP_SERVICE_UNAVAILABLE; + } else { + if ($remoteurl!~/\.meta$/) { + my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); + my $mresponse=$ua->request($mrequest,$filename.'.meta'); + if ($mresponse->is_error()) { + unlink($filename.'.meta'); + &logthis( + "INFO: No metadata: $filename"); + } + } + rename($transname,$filename); + return OK; + } + } +} + +# --------------------------------------------------------- Server Side Include + +sub ssi { + + my ($fn,%form)=@_; + + my $ua=new LWP::UserAgent; + + my $request; + + if (%form) { + $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); + $request->content(join '&', map { "$_=$form{$_}" } keys %form); + } else { + $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); + } + + $request->header(Cookie => $ENV{'HTTP_COOKIE'}); + my $response=$ua->request($request); + + return $response->content; +} + +# ------------------------------------------------------------------------- Log + +sub log { + my ($dom,$nam,$hom,$what)=@_; + return reply("log:$dom:$nam:$what",$hom); +} + +# ----------------------------------------------------------------------- Store + +sub store { + my %storehash=shift; + my $namevalue=''; + map { + $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; + } keys %storehash; + $namevalue=~s/\&$//; + return reply("store:$ENV{'user.domain'}:$ENV{'user.name'}:" + ."$ENV{'user.class'}:$ENV{'request.filename'}:$namevalue", + "$ENV{'user.home'}"); +} + +# --------------------------------------------------------------------- Restore + +sub restore { + my $answer=reply("restore:$ENV{'user.domain'}:$ENV{'user.name'}:" + ."$ENV{'user.class'}:$ENV{'request.filename'}", + "$ENV{'user.home'}"); + my %returnhash=(); + map { + my ($name,$value)=split(/\=/,$_); + $returnhash{&unescape($name)}=&unescape($value); + } split(/\&/,$answer); + return %returnhash; +} + +# -------------------------------------------------------- Get user priviledges + +sub rolesinit { + my ($domain,$username,$authhost)=@_; + my $rolesdump=reply("dump:$domain:$username:roles",$authhost); + if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } + my %allroles=(); + my %thesepriv=(); + my $now=time; + my $userroles="user.login.time=$now\n"; + my $thesestr; + + if ($rolesdump ne '') { + map { + if ($_!~/^rolesdef\&/) { + my ($area,$role)=split(/=/,$_); + $area=~s/\_\w\w$//; + my ($trole,$tend,$tstart)=split(/_/,$role); + $userroles.='user.role.'.$trole.'.'.$area.'='. + $tstart.'.'.$tend."\n"; + if ($tend!=0) { + if ($tend<$now) { + $trole=''; + } + } + if ($tstart!=0) { + if ($tstart>$now) { + $trole=''; + } + } + if (($area ne '') && ($trole ne '')) { + my ($tdummy,$tdomain,$trest)=split(/\//,$area); + if ($trole =~ /^cr\//) { + my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); + my $homsvr=homeserver($rauthor,$rdomain); + if ($hostname{$homsvr} ne '') { + my $roledef= + reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", + $homsvr); + if (($roledef ne 'con_lost') && ($roledef ne '')) { + my ($syspriv,$dompriv,$coursepriv)= + split(/\_/,unescape($roledef)); + $allroles{'/'}.=':'.$syspriv; + if ($tdomain ne '') { + $allroles{'/'.$tdomain.'/'}.=':'.$dompriv; + if ($trest ne '') { + $allroles{$area}.=':'.$coursepriv; + } + } + } + } + } else { + $allroles{'/'}.=':'.$pr{$trole.':s'}; + if ($tdomain ne '') { + $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + if ($trest ne '') { + $allroles{$area}.=':'.$pr{$trole.':c'}; + } + } + } + } + } + } split(/&/,$rolesdump); + map { + %thesepriv=(); + map { + if ($_ ne '') { + my ($priviledge,$restrictions)=split(/&/,$_); + if ($restrictions eq '') { + $thesepriv{$priviledge}='F'; + } else { + if ($thesepriv{$priviledge} ne 'F') { + $thesepriv{$priviledge}.=$restrictions; + } + } + } + } split(/:/,$allroles{$_}); + $thesestr=''; + map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv; + $userroles.='user.priv.'.$_.'='.$thesestr."\n"; + } keys %allroles; + } + return $userroles; +} + +# --------------------------------------------------------------- get interface + +sub get { + my ($namespace,@storearr)=@_; + my $items=''; + map { + $items.=escape($_).'&'; + } @storearr; + $items=~s/\&$//; + my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + map { + my ($key,$value)=split(/=/,$_); + $returnhash{unescape($key)}=unescape($value); + } @pairs; + return %returnhash; +} + +# --------------------------------------------------------------- del interface + +sub del { + my ($namespace,@storearr)=@_; + my $items=''; + map { + $items.=escape($_).'&'; + } @storearr; + $items=~s/\&$//; + return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); +} + +# -------------------------------------------------------------- dump interface + +sub dump { + my $namespace=shift; + my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace", + $ENV{'user.home'}); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + map { + my ($key,$value)=split(/=/,$_); + $returnhash{unescape($key)}=unescape($value); + } @pairs; + return %returnhash; +} + +# --------------------------------------------------------------- put interface + +sub put { + my ($namespace,%storehash)=@_; + my $items=''; + map { + $items.=escape($_).'='.escape($storehash{$_}).'&'; + } keys %storehash; + $items=~s/\&$//; + return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); +} + +# -------------------------------------------------------------- eget interface + +sub eget { + my ($namespace,@storearr)=@_; + my $items=''; + map { + $items.=escape($_).'&'; + } @storearr; + $items=~s/\&$//; + my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + map { + my ($key,$value)=split(/=/,$_); + $returnhash{unescape($key)}=unescape($value); + } @pairs; + return %returnhash; +} + +# ------------------------------------------------- Check for a user priviledge + +sub allowed { + my ($priv,$uri)=@_; + $uri=~s/^\/res//; + $uri=~s/^\///; + +# Free bre access to adm resources + + if (($uri=~/^adm\//) && ($priv eq 'bre')) { + return 'F'; + } + +# Gather priviledges over system and domain + + my $thisallowed=''; + if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + +# Full access at system or domain level? Exit. + + if ($thisallowed=~/F/) { + return 'F'; + } + +# The user does not have full access at system or domain level +# Course level access control + +# uri itself refering to a course? + + if ($uri=~/\.course$/) { + if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } +# Full access on course level? Exit. + if ($thisallowed=~/F/) { + return 'F'; + } + +# uri is refering to an individual resource; user needs to be in a course + + } else { + + unless(defined($ENV{'request.course.uri'})) { + return '1'; + } + +# Get access priviledges for course + + if ($ENV{'user.priv./'.$ENV{'request.course.uri'}}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + +# See if resource or referer is part of this course + + my @uriparts=split(/\//,$uri); + my $urifile=$uriparts[$#uriparts]; + $urifile=~/\.(\w+)$/; + my $uritype=$1; + $#uriparts--; + my $uripath=join('/',@uriparts); + my $uricond=-1; + if ($ENV{'acc.res.'.$ENV{'request.course'}.'.'.$uripath}=~ + /\&$urifile\:(\d+)\&/) { + $uricond=$1; + } elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) { + my $refuri=$ENV{'HTTP_REFERER'}; + $refuri=~s/^\/res//; + $refuri=~s/^\///; + @uriparts=split(/\//,$refuri); + $urifile=$uriparts[$#uriparts]; + $#uriparts--; + $uripath=join('/',@uriparts); + if ($ENV{'acc.res.'.$ENV{'request.course'}.'.'.$uripath}=~ + /\&$urifile\:(\d+)\&/) { + $uricond=$1; + } + } + + if ($uricond>=0) { + +# The resource is part of the course +# If user had full access on course level, go ahead + + if ($thisallowed=~/F/) { + return 'F'; + } + +# Restricted by state? + + if ($thisallowed=~/X/) { + if (&condval($uricond)>1) { + return '2'; + } else { + return ''; + } + } + } + } + return $thisallowed; +} + +# ---------------------------------------------------------- Refresh State Info + +sub refreshstate { +} + +# ----------------------------------------------------------------- Define Role + +sub definerole { + if (allowed('mcr','/')) { + my ($rolename,$sysrole,$domrole,$courole)=@_; + map { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } + if ($pr{'cr:s'}=~/$crole\&/) { + if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { + return "refused:s:$crole&$cqual"; + } + } + } split('/',$sysrole); + map { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } + if ($pr{'cr:d'}=~/$crole\&/) { + if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { + return "refused:d:$crole&$cqual"; + } + } + } split('/',$domrole); + map { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } + if ($pr{'cr:c'}=~/$crole\&/) { + if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { + 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=". + escape($sysrole.'_'.$domrole.'_'.$courole); + return reply($command,$ENV{'user.home'}); + } else { + return 'refused'; + } +} + +# ------------------------------------------------------------------ Plain Text + +sub plaintext { + my $short=shift; + return $prp{$short}; +} + +# ------------------------------------------------------------------ Plain Text + +sub fileembstyle { + my $ending=shift; + return $fe{$ending}; +} + +# ------------------------------------------------------------ Description Text + +sub filedecription { + my $ending=shift; + return $fd{$ending}; +} + +# ----------------------------------------------------------------- Assign Role + +sub assignrole { + my ($udom,$uname,$url,$role,$end,$start)=@_; + my $mrole; + $url=~s/^\///; + $url=~s/^res\///; + if ($role =~ /^cr\//) { + unless ($url=~/\.course$/) { return 'invalid'; } + unless (allowed('ccr',$url)) { return 'refused'; } + $mrole='cr'; + } else { + unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; } + unless (allowed('c'+$role)) { return 'refused'; } + $mrole=$role; + } + my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$udom:$uname:$url".'_'."$mrole=$role"; + if ($end) { $command.='_$end'; } + if ($start) { + if ($end) { + $command.='_$start'; + } else { + $command.='_0_$start'; + } + } + return &reply($command,&homeserver($uname,$udom)); +} + +# ---------------------------------------------------------- Assign Custom Role + +sub assigncustomrole { + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; + return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, + $end,$start); +} + +# ----------------------------------------------------------------- Revoke Role + +sub revokerole { + my ($udom,$uname,$url,$role)=@_; + my $now=time; + return &assignrole($udom,$uname,$url,$role,$now); +} + +# ---------------------------------------------------------- Revoke Custom Role + +sub revokecustomrole { + my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; + my $now=time; + return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); +} + +# ------------------------------------------------------------ Directory lister + +sub dirlist { + my $uri=shift; + $uri=~s/^\///; + $uri=~s/\/$//; + my ($res,$udom,$uname,@rest)=split(/\//,$uri); + if ($udom) { + if ($uname) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, + homeserver($uname,$udom)); + return split(/:/,$listing); + } else { + my $tryserver; + my %allusers=(); + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, + $tryserver); + if (($listing ne 'no_such_dir') && ($listing ne 'empty') + && ($listing ne 'con_lost')) { + map { + my ($entry,@stat)=split(/&/,$_); + $allusers{$entry}=1; + } split(/:/,$listing); + } + } + } + my $alluserstr=''; + map { + $alluserstr.=$_.'&user:'; + } sort keys %allusers; + $alluserstr=~s/:$//; + return split(/:/,$alluserstr); + } + } else { + my $tryserver; + my %alldom=(); + foreach $tryserver (keys %libserv) { + $alldom{$hostdom{$tryserver}}=1; + } + my $alldomstr=''; + map { + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; + } sort keys %alldom; + $alldomstr=~s/:$//; + return split(/:/,$alldomstr); + } +} + +# -------------------------------------------------------- Value of a Condition + +sub condval { + my $condidx=shift; + my $result=0; + if ($ENV{'request.course'}) { + if (defined($ENV{'acc.cond.'.$ENV{'request.course'}.'.'.$condidx})) { + my $operand='|'; + my @stack; + map { + if ($_ eq '(') { + push @stack,($operand,$result) + } elsif ($_ eq ')') { + my $before=pop @stack; + if (pop @stack eq '&') { + $result=$result>$before?$before:$result; + } else { + $result=$result>$before?$result:$before; + } + } elsif (($_ eq '&') || ($_ eq '|')) { + $operand=$_; + } else { + my $new= + substr($ENV{'user.state.'.$ENV{'request.course'}},$_,1); + if ($operand eq '&') { + $result=$result>$new?$new:$result; + } else { + $result=$result>$new?$result:$new; + } + } + } ($ENV{'acc.cond.'.$ENV{'request.course'}.'.'.$condidx}=~ + /(\d+|\(|\)|\&|\|)/g); + } + } + return $result; +} + +# --------------------------------------------------------- Value of a Variable + +sub varval { + my ($realm,$space,@components)=split(/\./,shift); + my $value=''; + if ($realm eq 'user') { + if ($space=~/^resource/) { + $space=~s/^resource\[//; + $space=~s/\]$//; + + } else { + } + } elsif ($realm eq 'course') { + } elsif ($realm eq 'session') { + } elsif ($realm eq 'system') { + } + return $value; +} + +# -------------------------------------------------------- Escape Special Chars + +sub escape { + my $str=shift; + $str =~ s/(\W)/"%".unpack('H2',$1)/eg; + return $str; +} + +# ----------------------------------------------------- Un-Escape Special Chars + +sub unescape { + my $str=shift; + $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + return $str; +} # ================================================================ Main Program @@ -245,6 +957,7 @@ if ($readit ne 'done') { while (my $configline=<$config>) { if ($configline =~ /PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); $perlvar{$varname}=$varvalue; } } @@ -273,11 +986,45 @@ if ($readit ne 'done') { } } } -$readit='done'; -&logthis('Read configuration'); +# ------------------------------------------------------------ Read permissions +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); + + while (my $configline=<$config>) { + chomp($configline); + my ($role,$perm)=split(/ /,$configline); + if ($perm ne '') { $pr{$role}=$perm; } + } } + +# -------------------------------------------- Read plain texts for permissions +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); + + while (my $configline=<$config>) { + chomp($configline); + my ($short,$plain)=split(/:/,$configline); + if ($plain ne '') { $prp{$short}=$plain; } + } } -1; +# ------------------------------------------------------------- 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); + } + } +} + +$readit='done'; +&logthis('INFO: Read configuration'); +} +} +1;