[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.957 and 1.962

version 1.957, 2008/04/30 22:42:59 version 1.962, 2008/06/26 19:54:19
Line 39  use vars qw(%perlvar %spareid %pr %prp $ Line 39  use vars qw(%perlvar %spareid %pr %prp $
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
     %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,      %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
     %courseownerbuf, %coursetypebuf);      %courseownerbuf, %coursetypebuf,$locknum);
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
Line 526  sub get_env_multiple { Line 526  sub get_env_multiple {
     return(@values);      return(@values);
 }  }
   
   # ------------------------------------------------------------------- Locking
   
   sub set_lock {
       my ($text)=@_;
       $locknum++;
       my $id=$$.'-'.$locknum;
       &appenv({'session.locks' => $env{'session.locks'}.','.$id,
                'session.lock.'.$id => $text});
       return $id;
   }
   
   sub get_locks {
       my $num=0;
       my %texts=();
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             $num++;
             $texts{$lock}=$env{'session.lock.'.$lock};
          }
      }
      return ($num,%texts);
   }
   
   sub remove_lock {
       my ($id)=@_;
       my $newlocks='';
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if (($lock=~/\w/) && ($lock ne $id)) {
             $newlocks.=','.$lock;
          }
       }
       &appenv({'session.locks' => $newlocks});
       &delenv('session.lock.'.$id);
   }
   
   sub remove_all_locks {
       my $activelocks=$env{'session.locks'};
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             &remove_lock($lock);
          }
       }
   }
   
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
Line 913  sub retrieve_inst_usertypes { Line 958  sub retrieve_inst_usertypes {
     if (defined(&domain($udom,'primary'))) {      if (defined(&domain($udom,'primary'))) {
         my $uhome=&domain($udom,'primary');          my $uhome=&domain($udom,'primary');
         my $rep=&reply("inst_usertypes:$udom",$uhome);          my $rep=&reply("inst_usertypes:$udom",$uhome);
           if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
               &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
               return (\%returnhash,\@order);
           }
         my ($hashitems,$orderitems) = split(/:/,$rep);           my ($hashitems,$orderitems) = split(/:/,$rep); 
         my @pairs=split(/\&/,$hashitems);          my @pairs=split(/\&/,$hashitems);
         foreach my $item (@pairs) {          foreach my $item (@pairs) {
Line 1841  sub process_coursefile { Line 1890  sub process_coursefile {
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
                 my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);                  my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
                 unless ($parse_result eq 'ok') {                  unless ($parse_result eq 'ok') {
                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);                      &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                 }                  }
Line 2049  sub finishuserfileupload { Line 2098  sub finishuserfileupload {
  close(FH);   close(FH);
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,          my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
    $codebase);     $codebase);
         unless ($parse_result eq 'ok') {          unless ($parse_result eq 'ok') {
             &logthis('Failed to parse '.$filepath.$file.              &logthis('Failed to parse '.$filepath.$file.
Line 2089  sub finishuserfileupload { Line 2138  sub finishuserfileupload {
 }  }
   
 sub extract_embedded_items {  sub extract_embedded_items {
     my ($filepath,$file,$allfiles,$codebase,$content) = @_;      my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();      my @state = ();
     my %javafiles = (      my %javafiles = (
                       codebase => '',                        codebase => '',
Line 2104  sub extract_embedded_items { Line 2153  sub extract_embedded_items {
     if ($content) {      if ($content) {
         $p = HTML::LCParser->new($content);          $p = HTML::LCParser->new($content);
     } else {      } else {
         $p = HTML::LCParser->new($filepath.'/'.$file);          $p = HTML::LCParser->new($fullpath);
     }      }
     while (my $t=$p->get_token()) {      while (my $t=$p->get_token()) {
  if ($t->[0] eq 'S') {   if ($t->[0] eq 'S') {
Line 2717  sub courseidput { Line 2766  sub courseidput {
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly)=@_;          $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 2735  sub courseiddump { Line 2784  sub courseiddump {
                          &escape($instcodefilter).':'.&escape($ownerfilter).                           &escape($instcodefilter).':'.&escape($ownerfilter).
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                           ':'.&escape($coursefilter).':'.&escape($typefilter).
                          ':'.&escape($regexp_ok).':'.$as_hash.':'.                           ':'.&escape($regexp_ok).':'.$as_hash.':'.
                          &escape($selfenrollonly),$tryserver);                           &escape($selfenrollonly).':'.&escape($catfilter).':'.
                            $showhidden.':'.$caller,$tryserver);
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 4489  sub allowed { Line 4539  sub allowed {
     }      }
           
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
     }      }
Line 8763  $memcache=new Cache::Memcached({'servers Line 8812  $memcache=new Cache::Memcached({'servers
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
   $locknum=0;
   
 &logtouch();  &logtouch();
 &logthis('<font color="yellow">INFO: Read configuration</font>');  &logthis('<font color="yellow">INFO: Read configuration</font>');
Removed from v.1.957  
changed lines
  Added in v.1.962

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