--- loncom/lonnet/perl/lonnet.pm 2003/07/03 19:26:21 1.386 +++ loncom/lonnet/perl/lonnet.pm 2003/08/14 22:26:40 1.402 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.386 2003/07/03 19:26:21 matthew Exp $ +# $Id: lonnet.pm,v 1.402 2003/08/14 22:26:40 bowersj2 Exp $ # # Copyright Michigan State University Board of Trustees # @@ -1284,6 +1284,53 @@ sub get_course_adv_roles { return %returnhash; } +sub get_my_roles { + my ($uname,$udom)=@_; + unless (defined($uname)) { $uname=$ENV{'user.name'}; } + unless (defined($udom)) { $udom=$ENV{'user.domain'}; } + my %dumphash= + &dump('nohist_userroles',$udom,$uname); + my %returnhash=(); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } + return %returnhash; +} + +# ----------------------------------------------------- Frontpage Announcements +# +# + +sub postannounce { + my ($server,$text)=@_; + unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless ($text=~/\w/) { $text=''; } + return &reply('setannounce:'.&escape($text),$server); +} + +sub getannounce { + if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { + my $announcement=''; + while (<$fh>) { $announcement .=$_; } + $fh->close(); + if ($announcement=~/\w/) { + return + ''. + '
'.$announcement.'
'; + } else { + return ''; + } + } else { + return ''; + } +} + # ---------------------------------------------------------- Course ID routines # Deal with domain's nohist_courseid.db files # @@ -1425,19 +1472,19 @@ sub devalidate { my ($symb,$uname,$udom)=@_; my $cid=$ENV{'request.course.id'}; if ($cid) { -# delete the stored spreadsheets for -# - the student level sheet of this user in course's homespace -# - the assessment level sheet for this resource -# for this user in user's homespace + # delete the stored spreadsheets for + # - the student level sheet of this user in course's homespace + # - the assessment level sheet for this resource + # for this user in user's homespace my $key=$uname.':'.$udom.':'; my $status= &del('nohist_calculatedsheets', - [$key.'studentcalc'], + [$key.'studentcalc:'], $ENV{'course.'.$cid.'.domain'}, $ENV{'course.'.$cid.'.num'}) .' '. &del('nohist_calculatedsheets_'.$cid, - [$key.'assesscalc:'.$symb]); + [$key.'assesscalc:'.$symb],$udom,$uname); unless ($status eq 'ok ok') { &logthis('Could not devalidate spreadsheet '. $uname.' at '.$udom.' for '. @@ -1936,14 +1983,14 @@ sub rolesinit { my ($tdummy,$tdomain,$trest)=split(/\//,$area); if ($trole =~ /^cr\//) { my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); - my $homsvr=homeserver($rauthor,$rdomain); + 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 ($rdummy,$roledef)= + &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); + + if (($rdummy ne 'con_lost') && ($roledef ne '')) { my ($syspriv,$dompriv,$coursepriv)= - split(/\_/,unescape($roledef)); + split(/\_/,$roledef); if (defined($syspriv)) { $allroles{'cm./'}.=':'.$syspriv; $allroles{$spec.'./'}.=':'.$syspriv; @@ -2209,6 +2256,9 @@ sub customaccess { $access=($effect eq 'allow'); last; } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } } return $access; } @@ -2221,6 +2271,7 @@ sub allowed { my $orguri=$uri; $uri=&declutter($uri); + if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # Free bre access to adm and meta resources if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { @@ -2521,7 +2572,7 @@ sub is_on_map { sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - foreach (split('/',$sysrole)) { + foreach (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } if ($pr{'cr:s'}=~/$crole\&/) { @@ -2530,7 +2581,7 @@ sub definerole { } } } - foreach (split('/',$domrole)) { + foreach (split(':',$domrole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } if ($pr{'cr:d'}=~/$crole\&/) { @@ -2539,7 +2590,7 @@ sub definerole { } } } - foreach (split('/',$courole)) { + foreach (split(':',$courole)) { my ($crole,$cqual)=split(/\&/,$_); if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } if ($pr{'cr:c'}=~/$crole\&/) { @@ -2651,7 +2702,9 @@ sub assignrole { my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; my $mrole; if ($role =~ /^cr\//) { - unless (&allowed('ccr',$url)) { + my $cwosec=$url; + $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. $ENV{'user.name'}.' at '.$ENV{'user.domain'}); @@ -2732,7 +2785,7 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome)=@_; + $forceid, $desiredhome, $email)=@_; $udom=~s/\W//g; $uname=~s/\W//g; &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. @@ -2801,10 +2854,17 @@ sub modifyuser { } else { %names = @tmp; } - if (defined($first)) { $names{'firstname'} = $first; } +# +# Make sure to not trash student environment if instructor does not bother +# to supply name and email information +# + if ($first) { $names{'firstname'} = $first; } if (defined($middle)) { $names{'middlename'} = $middle; } - if (defined($last)) { $names{'lastname'} = $last; } + if ($last) { $names{'lastname'} = $last; } if (defined($gene)) { $names{'generation'} = $gene; } + if ($email) { $names{'notification'} = $email; + $names{'critnotification'} = $email; } + my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -2818,7 +2878,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome)=@_; + $end,$start,$forceid,$desiredhome,$email)=@_; my $cid=''; unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; @@ -2826,7 +2886,7 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome); + $desiredhome,$email); unless ($reply eq 'ok') { return $reply; } # This will cause &modify_student_enrollment to get the uid from the # students environment @@ -3061,7 +3121,7 @@ sub dirlist { } my $alldomstr=''; foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; } $alldomstr=~s/:$//; return split(/:/,$alldomstr); @@ -3197,7 +3257,7 @@ sub clear_EXT_cache_status { sub EXT_cache_status { my ($target_domain,$target_user) = @_; my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; - if (exists($ENV{$cachename}) && ($ENV{$cachename}+1800) > time) { + if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { # We know already the user has no data return 1; } else { @@ -3213,7 +3273,7 @@ sub EXT_cache_set { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,$usection)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb @@ -3314,6 +3374,7 @@ sub EXT { return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { + my $section; if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -3326,7 +3387,6 @@ sub EXT { my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { $section=$ENV{'request.course.sec'}; @@ -3417,9 +3477,12 @@ sub EXT { my $part=join('_',@parts); if ($part eq '') { $part='0'; } my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm,$udom,$uname); + $symbparm,$udom,$uname,$section,1); if (defined($partgeneral)) { return $partgeneral; } } + if ($recurse) { return undef; } + my $pack_def=&packages_tab_default($filename,$varname); + if (defined($pack_def)) { return $pack_def; } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -3440,6 +3503,19 @@ sub EXT { return ''; } +sub packages_tab_default { + my ($uri,$varname)=@_; + my (undef,$part,$name)=split(/\./,$varname); + my $packages=&metadata($uri,'packages'); + foreach my $package (split(/,/,$packages)) { + my ($pack_type,$pack_part)=split(/_/,$package,2); + if ($pack_part eq $part) { + return $packagetab{"$pack_type&$name&default"}; + } + } + return undef; +} + sub add_prefix_and_part { my ($prefix,$part)=@_; my $keyroot; @@ -3481,14 +3557,15 @@ sub metadata { if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; - } + } else { + delete($metacache{$uri.':packages'}); + } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile(&filelocation('',&clutter($filename))); my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; - delete($metacache{$uri.':packages'}); while ($token=$parser->get_token) { if ($token->[0] eq 'S') { if (defined($token->[2]->{'package'})) { @@ -3508,6 +3585,9 @@ sub metadata { foreach (keys %packagetab) { if ($_=~/^$package\&/) { my ($pack,$name,$subp)=split(/\&/,$_); + # ignore package.tab specified default values + # here &package_tab_default() will fetch those + if ($subp eq 'default') { next; } my $value=$packagetab{$_}; my $part=$keyroot; $part=~s/^\_//; @@ -3515,13 +3595,8 @@ sub metadata { $value.=' [Part: '.$part.']'; } my $unikey='parameter'.$keyroot.'_'.$name; - if ($subp eq 'default') { - $unikey='parameter_0_'.$name; - $metacache{$uri.':'.$unikey.'.part'}='0'; - } else { - $metacache{$uri.':'.$unikey.'.part'}=$part; - $metathesekeys{$unikey}=1; - } + $metacache{$uri.':'.$unikey.'.part'}=$part; + $metathesekeys{$unikey}=1; unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { $metacache{$uri.':'.$unikey.'.'.$subp}=$value; } @@ -4093,7 +4168,8 @@ BEGIN { %domain_auth_arg_def = (); if ($fh) { while (<$fh>) { - next if /^\#/; + next if (/^(\#|\s*$)/); +# next if /^\#/; chomp; my ($domain, $domain_description, $def_auth, $def_auth_arg) = split(/:/,$_,4); @@ -4236,45 +4312,125 @@ being set. =back -=head1 INTRODUCTION +=head1 OVERVIEW -This module provides subroutines which interact with the -lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about -- classes -- users -- resources +lonnet provides subroutines which interact with the +lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask +about classes, users, and resources. For many of these objects you can also use this to store data about them or modify them in various ways. -This is part of the LearningOnline Network with CAPA project -described at http://www.lon-capa.org. +=head2 Symbs -=head1 RETURN MESSAGES +To identify a specific instance of a resource, LON-CAPA uses symbols +or "symbs"X. These identifiers are built from the URL of the +map, the resource number of the resource in the map, and the URL of +the resource itself. The latter is somewhat redundant, but might help +if maps change. -=over 4 +An example is -=item * + msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem -con_lost : unable to contact remote host +The respective map entry is -=item * + + -con_delayed : unable to contact remote host, message will be delivered -when the connection is brought back up +Symbs are used by the random number generator, as well as to store and +restore data specific to a certain instance of for example a problem. -=item * +=head2 Storing And Retrieving Data -con_failed : unable to contact remote host and unable to save message -for later delivery +XXXThree of the most important functions +in C are C<&Apache::lonnet::cstore()>, +C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which +is is the non-critical message twin of cstore. These functions are for +handlers to store a perl hash to a user's permanent data space in an +easy manner, and to retrieve it again on another call. It is expected +that a handler would use this once at the beginning to retrieve data, +and then again once at the end to send only the new data back. -=item * +The data is stored in the user's data directory on the user's +homeserver under the ID of the course. -error: : an error a occured, a description of the error follows the : +The hash that is returned by restore will have all of the previous +value for all of the elements of the hash. -=item * +Example: + + #creating a hash + my %hash; + $hash{'foo'}='bar'; + + #storing it + &Apache::lonnet::cstore(\%hash); + + #changing a value + $hash{'foo'}='notbar'; + + #adding a new value + $hash{'bar'}='foo'; + &Apache::lonnet::cstore(\%hash); + + #retrieving the hash + my %history=&Apache::lonnet::restore(); + + #print the hash + foreach my $key (sort(keys(%history))) { + print("\%history{$key} = $history{$key}"); + } + +Will print out: + + %history{1:foo} = bar + %history{1:keys} = foo:timestamp + %history{1:timestamp} = 990455579 + %history{2:bar} = foo + %history{2:foo} = notbar + %history{2:keys} = foo:bar:timestamp + %history{2:timestamp} = 990455580 + %history{bar} = foo + %history{foo} = notbar + %history{timestamp} = 990455580 + %history{version} = 2 + +Note that the special hash entries C, C and +C were added to the hash. C will be equal to the +total number of versions of the data that have been stored. The +C attribute will be the UNIX time the hash was +stored. C is available in every historical section to list which +keys were added or changed at a specific historical revision of a +hash. + +B: do not store the hash that restore returns directly. This +will cause a mess since it will restore the historical keys as if the +were new keys. I.E. 1:foo will become 1:1:foo etc. + +Calling convention: + + my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); + +For more detailed information, see lonnet specific documentation. + +=head1 RETURN MESSAGES -no_such_host : unable to fund a host associated with the user/domain +=over 4 + +=item * B: unable to contact remote host + +=item * B: unable to contact remote host, message will be delivered +when the connection is brought back up + +=item * B: unable to contact remote host and unable to save message +for later delivery + +=item * B: an error a occured, a description of the error follows the : + +=item * B: unable to fund a host associated with the user/domain that was requested =back @@ -4285,15 +4441,18 @@ that was requested =over 4 -=item * - -appenv(%hash) : the value of %hash is written to the user envirnoment -file, and will be restored for each access this user makes during this -session, also modifies the %ENV for the current process +=item * +X +B: the value of %hash is written to +the user envirnoment file, and will be restored for each access this +user makes during this session, also modifies the %ENV for the current +process =item * - -delenv($regexp) : removes all items from the session environment file that matches the regular expression in $regexp. The values are also delted from the current processes %ENV. +X +B: removes all items from the session +environment file that matches the regular expression in $regexp. The +values are also delted from the current processes %ENV. =back @@ -4302,50 +4461,51 @@ delenv($regexp) : removes all items from =over 4 =item * - -queryauthenticate($uname,$udom) : try to determine user's current +X +B: 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), $upass should be the users password +X +B: try to +authenticate user from domain's lib servers (first use the current +one). C<$upass> should be the users password. =item * - -homeserver($uname,$udom) : find the server which has the user's -directory and files (there must be only one), this caches the answer, -and also caches if there is a borken connection. +X +B: find the server which has +the user's directory and files (there must be only one), this caches +the answer, and also caches if there is a borken connection. =item * - -idget($udom,@ids) : find the usernames behind a list of IDs (IDs are a -unique resource in a domain, there must be only 1 ID per username, and -only 1 username per ID in a specific domain) (returns hash: -id=>name,id=>name) +X +B: find the usernames behind a list of IDs +(IDs are a unique resource in a domain, there must be only 1 ID per +username, and only 1 username per ID in a specific domain) (returns +hash: id=>name,id=>name) =item * - -idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash: -name=>id,name=>id) +X +B: 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 +X +B: store away a list of names and associated IDs =item * - -rolesinit($udom,$username,$authhost) : get user privileges +X +B: get user privileges =item * - -usection($udom,$uname,$cname) : finds the section of student in the +X +B: finds the section of student in the course $cname, return section name/number or '' for "not in course" and '-1' for "no section" =item * - -userenvironment($udom,$uname,@what) : gets the values of the keys +X +B: gets the values of the keys passed in @what from the requested user's environment, returns a hash =back