[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.915 and 1.921

version 1.915, 2007/10/01 21:06:04 version 1.921, 2007/10/06 04:32:40
Line 320  sub convert_and_load_session_env { Line 320  sub convert_and_load_session_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
     my @profile;      my @profile;
     {      {
  open(my $idf,'+<',"$lonidsdir/$handle.id");   my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
  if (!$idf) {   if (!$opened) {
     return 0;      return 0;
  }   }
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
Line 362  sub transfer_profile_to_env { Line 362  sub transfer_profile_to_env {
   
     my $convert;      my $convert;
     {      {
     open(my $idf,'+<',"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
  if (!$idf) {   if (!$opened) {
     return;      return;
  }   }
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
Line 397  sub transfer_profile_to_env { Line 397  sub transfer_profile_to_env {
     }      }
 }  }
   
   # ---------------------------------------------------- Check for valid session 
   sub check_for_valid_session {
       my ($r) = @_;
       my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
       my $lonid=$cookies{'lonID'};
       return undef if (!$lonid);
   
       my $handle=&LONCAPA::clean_handle($lonid->value);
       my $lonidsdir=$r->dir_config('lonIDsDir');
       return undef if (!-e "$lonidsdir/$handle.id");
   
       my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
       return undef if (!$opened);
   
       flock($idf,LOCK_SH);
       my %disk_env;
       if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
       &GDBM_READER(),0640)) {
    return undef;
       }
   
       if (!defined($disk_env{'user.name'})
    || !defined($disk_env{'user.domain'})) {
    return undef;
       }
       return $handle;
   }
   
 sub timed_flock {  sub timed_flock {
     my ($file,$lock_type) = @_;      my ($file,$lock_type) = @_;
     my $failed=0;      my $failed=0;
Line 431  sub appenv { Line 459  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
     open(my $env_file,'+<',$env{'user.environment'});      my $opened = open(my $env_file,'+<',$env{'user.environment'});
     if ($env_file      if ($opened
  && &timed_flock($env_file,LOCK_EX)   && &timed_flock($env_file,LOCK_EX)
  &&   &&
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
Line 453  sub delenv { Line 481  sub delenv {
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     open(my $env_file,'+<',$env{'user.environment'});      my $opened = open(my $env_file,'+<',$env{'user.environment'});
     if ($env_file      if ($opened
  && &timed_flock($env_file,LOCK_EX)   && &timed_flock($env_file,LOCK_EX)
  &&   &&
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
Line 1355  sub do_cache_new { Line 1383  sub do_cache_new {
  $memcache->disconnect_all();   $memcache->disconnect_all();
     }      }
     # need to make a copy of $value      # need to make a copy of $value
     #&make_room($id,$value,$debug);      &make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($id,$value,$debug)=@_;
     $remembered{$id}=$value;  
       $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
                                       : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
Line 2142  sub flushcourselogs { Line 2172  sub flushcourselogs {
 # times and course titles for all courseids  # times and course titles for all courseids
 #  #
     my %courseidbuffer=();      my %courseidbuffer=();
     foreach my $crsid (keys %courselogs) {      foreach my $crsid (keys(%courselogs)) {
         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
Line 2155  sub flushcourselogs { Line 2185  sub flushcourselogs {
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }          }
         if ($courseidbuffer{$coursehombuf{$crsid}}) {          $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.              'description' => &escape($coursedescrbuf{$crsid}),
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).              'inst_code'    => &escape($courseinstcodebuf{$crsid}),
                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});              'type'        => &escape($coursetypebuf{$crsid}),
         } else {              'owner'       => &escape($courseownerbuf{$crsid}),
            $courseidbuffer{$coursehombuf{$crsid}}=          };
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).  
                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});  
         }  
     }      }
 #  #
 # Write course id database (reverse lookup) to homeserver of courses   # Write course id database (reverse lookup) to homeserver of courses 
 # Is used in pickcourse  # Is used in pickcourse
 #  #
     foreach my $crs_home (keys(%courseidbuffer)) {      foreach my $crs_home (keys(%courseidbuffer)) {
         &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},          my $response = &courseidput(&host_domain($crs_home),
      $crs_home);                                      $courseidbuffer{$crs_home},
                                       $crs_home,'timeonly');
     }      }
 #  #
 # File accesses  # File accesses
Line 2477  sub getannounce { Line 2505  sub getannounce {
 #  #
   
 sub courseidput {  sub courseidput {
     my ($domain,$what,$coursehome)=@_;      my ($domain,$storehash,$coursehome,$caller) = @_;
     return &reply('courseidput:'.$domain.':'.$what,$coursehome);      my $outcome;
       if ($caller eq 'timeonly') {
           my $cids = '';
           foreach my $item (keys(%$storehash)) {
               $cids.=&escape($item).'&';
           }
           $cids=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
                             $coursehome);       
       } else {
           my $items = '';
           foreach my $item (keys(%$storehash)) {
               $items.= &escape($item).'='.
                        &freeze_escape($$storehash{$item}).'&';
           }
           $items=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
                             $coursehome);
       }
       if ($outcome eq 'unknown_cmd') {
           my $what;
           foreach my $cid (keys(%$storehash)) {
               $what .= &escape($cid).'=';
               foreach my $item ('description','inst_code','owner','type') {
                   $what .= &escape($storehash->{$item}).':';
               }
               $what =~ s/\:$/&/;
           }
           $what =~ s/\&$//;  
           return &reply('courseidput:'.$domain.':'.$what,$coursehome);
       } else {
           return $outcome;
       }
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
     my %returnhash=();          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
     unless ($domfilter) { $domfilter=''; }      my $as_hash = 1;
       my %returnhash;
       if (!$domfilter) { $domfilter=''; }
     my %libserv = &all_library();      my %libserv = &all_library();
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if ( (  $hostidflag == 1           if ( (  $hostidflag == 1 
         && grep(/^\Q$tryserver\E$/,@{$hostidref}) )           && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 
      || (!defined($hostidflag)) ) {       || (!defined($hostidflag)) ) {
   
     if ($domfilter eq ''      if (($domfilter eq '') ||
  || (&host_domain($tryserver) eq $domfilter)) {   (&host_domain($tryserver) eq $domfilter)) {
         foreach my $line (                  my $rep = 
                  split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.                    &reply('courseiddump:'.&host_domain($tryserver).':'.
        $sincefilter.':'.&escape($descfilter).':'.                           $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),                           &escape($instcodefilter).':'.&escape($ownerfilter).
                                $tryserver))) {                           ':'.&escape($coursefilter).':'.&escape($typefilter).
     my ($key,$value)=split(/\=/,$line,2);                           ':'.&escape($regexp_ok).':'.$as_hash,$tryserver);
                     if (($key) && ($value)) {                  my @pairs=split(/\&/,$rep);
         $returnhash{&unescape($key)}=$value;                  foreach my $item (@pairs) {
                     }                      my ($key,$value)=split(/\=/,$item,2);
                       $key = &unescape($key);
                       next if ($key =~ /^error: 2 /);
                       my $result = &thaw_unescape($value);
                       if (ref($result) eq 'HASH') {
                           $returnhash{$key}=$result;
                       } else {
                           my @responses = split(/:/,$value);
                           my @items = ('description','inst_code','owner','type');
                           for (my $i=0; $i<@responses; $i++) {
                               $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
                           }
                       } 
                 }                  }
             }              }
         }          }
Line 4947  sub auto_instcode_defaults { Line 5021  sub auto_instcode_defaults {
 }   } 
   
 sub auto_validate_class_sec {  sub auto_validate_class_sec {
     my ($cdom,$cnum,$owner,$inst_class) = @_;      my ($cdom,$cnum,$owners,$inst_class) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $ownerlist;
       if (ref($owners) eq 'ARRAY') {
           $ownerlist = join(',',@{$owners});
       } else {
           $ownerlist = $owners;
       }
     my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.      my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
                         &escape($owner).':'.$cdom,$homeserver);                          &escape($ownerlist).':'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
   
Line 5479  sub createcourse { Line 5559  sub createcourse {
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existence  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).      my $newcourse = {
                  ':'.&escape($inst_code).':'.&escape($course_owner).':'.                      $udom.'_'.$uname => {
                   &escape($crstype),$uhome);                                       description => $description,
     &flushcourselogs();                                       inst_code   => $inst_code,
                                        owner       => $course_owner,
                                        type        => $crstype,
                                                   },
                       };
       &courseidput($udom,$newcourse,$uhome,'notime');
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
     unless ($nonstandard) {      unless ($nonstandard) {
Line 5512  ENDINITMAP Line 5597  ENDINITMAP
 sub is_course {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,      my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
  undef,'.');   undef,'.',undef,1);
     if (exists($courses{$cdom.'_'.$cnum})) {      if (exists($courses{$cdom.'_'.$cnum})) {
         return 1;          return 1;
     }      }
Removed from v.1.915  
changed lines
  Added in v.1.921

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