[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.488 and 1.489.2.4

version 1.488, 2012/04/11 01:07:18 version 1.489.2.4, 2013/04/07 17:42:16
Line 34  use strict; Line 34  use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use LONCAPA;  use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   use LONCAPA::Lond;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
Line 2373  sub fetch_user_file_handler { Line 2374  sub fetch_user_file_handler {
  unlink($transname);   unlink($transname);
  &Failure($client, "failed\n", $userinput);   &Failure($client, "failed\n", $userinput);
     } else {      } else {
                   if ($fname =~ /^default.+\.(page|sequence)$/) {
                       my ($major,$minor) = split(/\./,$clientversion);
                       if (($major < 2) || ($major == 2 && $minor < 11)) {
                           my $now = time;
                           &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600);
                           my $key = &escape('internal.contentchange');
                           my $what = "$key=$now";
                           my $hashref = &tie_user_hash($udom,$uname,'environment',
                                                        &GDBM_WRCREAT(),"P",$what);
                           if ($hashref) {
                               $hashref->{$key}=$now;
                               if (!&untie_user_hash($hashref)) {
                                   &logthis("error: ".($!+0)." untie (GDBM) failed ".
                                            "when updating internal.contentchange");
                               }
                           }
                       }
                   }
  &Reply($client, "ok\n", $userinput);   &Reply($client, "ok\n", $userinput);
     }      }
  }      }   
Line 3248  sub dump_profile_database { Line 3267  sub dump_profile_database {
 #                               range       - optional range of entries  #                               range       - optional range of entries
 #                                             e.g., 10-20 would return the  #                                             e.g., 10-20 would return the
 #                                             10th to 19th items, etc.    #                                             10th to 19th items, etc.  
 #                               extra       - optional ref to hash of  
 #                                             additional args. currently  
 #                                             skipcheck is only key used.     
 #   $client                   - Channel open on the client.  #   $client                   - Channel open on the client.
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
Line 3260  sub dump_profile_database { Line 3276  sub dump_profile_database {
 sub dump_with_regexp {  sub dump_with_regexp {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
       my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);
   
     my $userinput = "$cmd:$tail";      if ($res =~ /^error:/) {
           &Failure($client, \$res, "$cmd:$tail");
     my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);  
     if (defined($regexp)) {  
  $regexp=&unescape($regexp);  
     } else {  
  $regexp='.';  
     }  
     my ($start,$end);  
     if (defined($range)) {  
  if ($range =~/^(\d+)\-(\d+)$/) {  
     ($start,$end) = ($1,$2);  
  } elsif ($range =~/^(\d+)$/) {  
     ($start,$end) = (0,$1);  
  } else {  
     undef($range);  
  }  
     }  
     my $hashref = &tie_user_hash($udom, $uname, $namespace,  
  &GDBM_READER());  
     my $skipcheck;  
     if ($hashref) {  
         my $qresult='';  
  my $count=0;  
 #  
 # When dump is for roles.db, determine if LON-CAPA version checking is needed.  
 # Sessions on 2.10 and later will include skipcheck => 1 in extra args ref,  
 # to indicate no version checking is needed (in this case, checking occurs  
 # on the server hosting the user session, when constructing the roles/courses   
 # screen).  
 #   
         if ($extra ne '') {  
             $extra = &Apache::lonnet::thaw_unescape($extra);  
             $skipcheck = $extra->{'skipcheck'};  
         }  
         my @ids = &Apache::lonnet::current_machine_ids();  
         my (%homecourses,$major,$minor,$now);  
 #   
 # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA     
 # version on the server which requested the data. For LON-CAPA 2.9, the    
 # client session will have sent its LON-CAPA version when initiating the  
 # connection. For LON-CAPA 2.8 and older, the version is retrieved from  
 # the global %loncaparevs in lonnet.pm.  
 #   
         if (($namespace eq 'roles') && (!$skipcheck)) {  
             my $loncaparev = $clientversion;  
             if ($loncaparev eq '') {  
                 $loncaparev = $Apache::lonnet::loncaparevs{$clientname};  
             }  
             if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {  
                 $major = $1;  
                 $minor = $2;  
             }  
             $now = time;  
         }  
  while (my ($key,$value) = each(%$hashref)) {  
             if ($namespace eq 'roles') {  
                 if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {  
                     my $cdom = $1;  
                     my $cnum = $2;  
                     unless ($skipcheck) {  
                         my ($role,$roleend,$rolestart) = split(/\_/,$value);  
                         if (!$roleend || $roleend > $now) {  
 #  
 # For active course roles, check that requesting server is running a LON-CAPA  
 # version which meets any version requirements for the course. Do not include  
 # the role amongst the results returned if the requesting server's version is  
 # too old.  
 #  
 # This determination is handled differently depending on whether the course's   
 # homeserver is the current server, or whether it is a different server.  
 # In both cases, the course's version requirement needs to be retrieved.  
 #   
                             next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,  
                                                             $minor,\%homecourses,\@ids));  
                         }  
                     }  
                 }  
             }  
     if ($regexp eq '.') {  
  $count++;  
  if (defined($range) && $count >= $end)   { last; }  
  if (defined($range) && $count <  $start) { next; }  
  $qresult.=$key.'='.$value.'&';  
     } else {  
  my $unescapeKey = &unescape($key);  
  if (eval('$unescapeKey=~/$regexp/')) {  
     $count++;  
     if (defined($range) && $count >= $end)   { last; }  
     if (defined($range) && $count <  $start) { next; }  
     $qresult.="$key=$value&";  
  }  
     }  
  }  
  if (&untie_user_hash($hashref)) {  
 #  
 # If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA  
 # version requirements for courses for which the current server is the home  
 # server permit course roles to be usable on the client server hosting the  
 # user's session. If so, include those role results in the data returned to    
 # the client server.  
 #  
             if (($namespace eq 'roles') && (!$skipcheck)) {  
                 if (keys(%homecourses) > 0) {  
                     $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,  
                                                    $range,$start,$end,$major,$minor);  
                 }  
             }  
     chop($qresult);  
     &Reply($client, \$qresult, $userinput);  
  } else {  
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".  
      "while attempting dump\n", $userinput);  
  }  
     } else {      } else {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".          &Reply($client, \$res, "$cmd:$tail");
  "while attempting dump\n", $userinput);  
     }      }
   
     return 1;      return 1;
Line 5092  sub validate_instcode_handler { Line 4996  sub validate_instcode_handler {
     my ($dom,$instcode,$owner) = split(/:/, $tail);      my ($dom,$instcode,$owner) = split(/:/, $tail);
     $instcode = &unescape($instcode);      $instcode = &unescape($instcode);
     $owner = &unescape($owner);      $owner = &unescape($owner);
     my ($outcome,$description) =       my ($outcome,$description,$credits) = 
         &localenroll::validate_instcode($dom,$instcode,$owner);          &localenroll::validate_instcode($dom,$instcode,$owner);
     my $result = &escape($outcome).'&'.&escape($description);      my $result = &escape($outcome).'&'.&escape($description).'&'.
                    &escape($credits);
     &Reply($client, \$result, $userinput);      &Reply($client, \$result, $userinput);
   
     return 1;      return 1;
Line 6565  sub make_new_child { Line 6470  sub make_new_child {
 #---------------------------------------------------- kerberos 5 initialization  #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
  unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||     unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||  
  ($dist eq 'fedora6') || ($dist eq 'suse9.3')) {   ($dist eq 'fedora6') || ($dist eq 'suse9.3') ||
                   ($dist eq 'suse12.2') || ($dist eq 'suse12.3')) {
     &Authen::Krb5::init_ets();      &Authen::Krb5::init_ets();
  }   }
   
Line 6611  sub make_new_child { Line 6517  sub make_new_child {
  #  If the remote is attempting a local init... give that a try:   #  If the remote is attempting a local init... give that a try:
  #   #
  (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);   (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
                   # For LON-CAPA 2.9, the  client session will have sent its LON-CAPA
                   # version when initiating the connection. For LON-CAPA 2.8 and older,
                   # the version is retrieved from the global %loncaparevs in lonnet.pm.
                   # $clientversion contains path to keyfile if $inittype eq 'local'
                   # it's overridden below in this case
                   $clientversion ||= $Apache::lonnet::loncaparevs{$clientname};
   
  # If the connection type is ssl, but I didn't get my   # If the connection type is ssl, but I didn't get my
  # certificate files yet, then I'll drop  back to    # certificate files yet, then I'll drop  back to 
Line 7474  sub get_usersession_config { Line 7386  sub get_usersession_config {
     return;      return;
 }  }
   
 #  
 # releasereqd_check() will determine if a LON-CAPA version (defined in the  
 # $major,$minor args passed) is not too old to allow use of a role in a   
 # course ($cnum,$cdom args passed), if at least one of the following applies:   
 # (a) the course is a Community, (b) the course's home server is *not* the  
 # current server, or (c) cached course information is not stale.   
 #  
 # For the case where none of these apply, the course is added to the   
 # $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).  
 # The $homecourse hash ref is for courses for which the current server is the   
 # home server.  LON-CAPA version requirements are checked elsewhere for the  
 # items in $homecourse.  
 #  
   
 sub releasereqd_check {  
     my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;  
     my $home = &Apache::lonnet::homeserver($cnum,$cdom);  
     return if ($home eq 'no_host');  
     my ($reqdmajor,$reqdminor,$displayrole);  
     if ($cnum =~ /$LONCAPA::match_community/) {  
         if ($major eq '' && $minor eq '') {  
             return unless ((ref($ids) eq 'ARRAY') &&   
                            (grep(/^\Q$home\E$/,@{$ids})));  
         } else {  
             $reqdmajor = 2;  
             $reqdminor = 9;  
             return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));  
         }  
     }  
     my $hashid = $cdom.':'.$cnum;  
     my ($courseinfo,$cached) =  
         &Apache::lonnet::is_cached_new('courseinfo',$hashid);  
     if (defined($cached)) {  
         if (ref($courseinfo) eq 'HASH') {  
             if (exists($courseinfo->{'releaserequired'})) {  
                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});  
                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));  
             }  
         }  
     } else {  
         if (ref($ids) eq 'ARRAY') {  
             if (grep(/^\Q$home\E$/,@{$ids})) {  
                 if (ref($homecourses) eq 'HASH') {  
                     if (ref($homecourses->{$hashid}) eq 'ARRAY') {  
                         push(@{$homecourses->{$hashid}},{$key=>$value});  
                     } else {  
                         $homecourses->{$hashid} = [{$key=>$value}];  
                     }  
                 }  
                 return;  
             }  
         }  
         my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);  
         if (ref($courseinfo) eq 'HASH') {  
             if (exists($courseinfo->{'releaserequired'})) {  
                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});  
                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));  
             }  
         } else {  
             return;  
         }  
     }  
     return 1;  
 }  
   
 #   
 # get_courseinfo_hash() is used to retrieve course information from the db  
 # file: nohist_courseids.db for a course for which the current server is *not*  
 # the home server.  
 #  
 # A hash of a hash will be retrieved. The outer hash contains a single key --  
 # courseID -- for the course for which the data are being requested.  
 # The contents of the inner hash, for that single item in the outer hash  
 # are returned (and cached in memcache for 10 minutes).  
 #   
   
 sub get_courseinfo_hash {  
     my ($cnum,$cdom,$home) = @_;  
     my %info;  
     eval {  
         local($SIG{ALRM}) = sub { die "timeout\n"; };  
         local($SIG{__DIE__})='DEFAULT';  
         alarm(3);  
         %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');  
         alarm(0);  
     };  
     if ($@) {  
         if ($@ eq "timeout\n") {  
             &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");  
         } else {  
             &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");  
         }  
     } else {  
         if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {  
             my $hashid = $cdom.':'.$cnum;  
             return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);  
         }  
     }  
     return;  
 }  
   
 #  
 # check_homecourses() will retrieve course information for those courses which  
 # are keys of the $homecourses hash ref (first arg). The nohist_courseids.db   
 # GDBM file is tied and course information for each course retrieved. Last     
 # visit (lasttime key) is also retrieved for each, and cached values updated    
 # for any courses last visited less than 24 hours ago. Cached values are also  
 # updated for any courses included in the $homecourses hash ref.  
 #  
 # The reason for the 24 hours constraint is that the cron entry in   
 # /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes   
 # cached course information to be updated nightly for courses with activity  
 # within the past 24 hours.  
 #  
 # Role information for the user (included in a ref to an array of hashes as the  
 # value for each key in $homecourses) is appended to the result returned by the  
 # routine, which will in turn be appended to the string returned to the client  
 # hosting the user's session.  
 #   
   
 sub check_homecourses {  
     my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;  
     my ($result,%addtocache);  
     my $yesterday = time - 24*3600;   
     if (ref($homecourses) eq 'HASH') {  
         my (%okcourses,%courseinfo,%recent);  
         my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());  
         if ($hashref) {  
             while (my ($key,$value) = each(%$hashref)) {  
                 my $unesc_key = &unescape($key);  
                 if ($unesc_key =~ /^lasttime:(\w+)$/) {  
                     my $cid = $1;  
                     $cid =~ s/_/:/;  
                     if ($value > $yesterday ) {  
                         $recent{$cid} = 1;  
                     }  
                     next;  
                 }  
                 my $items = &Apache::lonnet::thaw_unescape($value);  
                 if (ref($items) eq 'HASH') {  
                     my $hashid = $unesc_key;  
                     $hashid =~ s/_/:/;  
                     $courseinfo{$hashid} = $items;  
                     if (ref($homecourses->{$hashid}) eq 'ARRAY') {  
                         my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});  
                         if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {  
                             $okcourses{$hashid} = 1;  
                         }  
                     }  
                 }  
             }  
             unless (&untie_domain_hash($hashref)) {  
                 &logthis('Failed to untie tied hash for nohist_courseids.db');  
             }  
         } else {  
             &logthis('Failed to tie hash for nohist_courseids.db');  
             return;  
         }  
         foreach my $hashid (keys(%recent)) {  
             my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);  
             unless ($cached) {  
                 &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);  
             }  
         }  
         foreach my $hashid (keys(%{$homecourses})) {  
             next if ($recent{$hashid});  
             &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);  
         }  
         foreach my $hashid (keys(%okcourses)) {  
             if (ref($homecourses->{$hashid}) eq 'ARRAY') {  
                 foreach my $role (@{$homecourses->{$hashid}}) {  
                     if (ref($role) eq 'HASH') {  
                         while (my ($key,$value) = each(%{$role})) {  
                             if ($regexp eq '.') {  
                                 $count++;  
                                 if (defined($range) && $count >= $end)   { last; }  
                                 if (defined($range) && $count <  $start) { next; }  
                                 $result.=$key.'='.$value.'&';  
                             } else {  
                                 my $unescapeKey = &unescape($key);  
                                 if (eval('$unescapeKey=~/$regexp/')) {  
                                     $count++;  
                                     if (defined($range) && $count >= $end)   { last; }  
                                     if (defined($range) && $count <  $start) { next; }  
                                     $result.="$key=$value&";  
                                 }  
                             }  
                         }  
                     }  
                 }  
             }  
         }  
     }  
     return $result;  
 }  
   
 #  
 # useable_role() will compare the LON-CAPA version required by a course with   
 # the version available on the client server.  If the client server's version  
 # is compatible, 1 will be returned.  
 #  
   
 sub useable_role {  
     my ($reqdmajor,$reqdminor,$major,$minor) = @_;   
     if ($reqdmajor ne '' && $reqdminor ne '') {  
         return if (($major eq '' && $minor eq '') ||  
                    ($major < $reqdmajor) ||  
                    (($major == $reqdmajor) && ($minor < $reqdminor)));  
     }  
     return 1;  
 }  
   
 sub distro_and_arch {  sub distro_and_arch {
     return $dist.':'.$arch;      return $dist.':'.$arch;
Line 7897  Place in B<logs/lond.log> Line 7598  Place in B<logs/lond.log>
   
 stores hash in namespace  stores hash in namespace
   
 =item rolesputy  =item rolesput
   
 put a role into a user's environment  put a role into a user's environment
   
Removed from v.1.488  
changed lines
  Added in v.1.489.2.4

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>