[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.822 and 1.824.2.5

version 1.822, 2007/01/11 21:09:10 version 1.824.2.5, 2007/05/02 22:01:32
Line 367  sub transfer_profile_to_env { Line 367  sub transfer_profile_to_env {
     }      }
 }  }
   
   sub timed_flock {
       my ($file,$lock_type) = @_;
       my $failed=0;
       eval {
    local $SIG{__DIE__}='DEFAULT';
    local $SIG{ALRM}=sub {
       $failed=1;
       die("failed lock");
    };
    alarm(13);
    flock($file,$lock_type);
    alarm(0);
       };
       if ($failed) {
    return undef;
       } else {
    return 1;
       }
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
Line 381  sub appenv { Line 401  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
     if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),      open(my $env_file,$env{'user.environment'});
     0640)) {      if (&timed_flock($env_file,LOCK_EX)
    &&
    tie(my %disk_env,'GDBM_File',$env{'user.environment'},
       (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  while (my ($key,$value) = each(%newenv)) {   while (my ($key,$value) = each(%newenv)) {
     $disk_env{$key} = $value;      $disk_env{$key} = $value;
  }   }
Line 399  sub delenv { Line 422  sub delenv {
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),      open(my $env_file,$env{'user.environment'});
     0640)) {      if (&timed_flock($env_file,LOCK_EX)
    &&
    tie(my %disk_env,'GDBM_File',$env{'user.environment'},
       (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  foreach my $key (keys(%disk_env)) {   foreach my $key (keys(%disk_env)) {
     if ($key=~/^$delthis/) {       if ($key=~/^$delthis/) { 
                 delete($env{$key});                  delete($env{$key});
Line 964  my %remembered; Line 990  my %remembered;
 my %accessed;  my %accessed;
 my $kicks=0;  my $kicks=0;
 my $hits=0;  my $hits=0;
   sub make_key {
       my ($name,$id) = @_;
       if (length($id) > 65 
    && length(&escape($id)) > 200) {
    $id=length($id).':'.&Digest::MD5::md5_hex($id);
       }
       return &escape($name.':'.$id);
   }
   
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$id});
     delete($accessed{$id});      delete($accessed{$id});
Line 975  sub devalidate_cache_new { Line 1010  sub devalidate_cache_new {
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     if (exists($remembered{$id})) {      if (exists($remembered{$id})) {
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }   if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
  $accessed{$id}=[&gettimeofday()];   $accessed{$id}=[&gettimeofday()];
Line 998  sub is_cached_new { Line 1033  sub is_cached_new {
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
  $setvalue='__undef__';   $setvalue='__undef__';
Line 1007  sub do_cache_new { Line 1042  sub do_cache_new {
  $time=600;   $time=600;
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     $memcache->set($id,$setvalue,$time);      if (!($memcache->set($id,$setvalue,$time))) {
    &logthis("caching of id -> $id  failed");
       }
     # 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;
Line 1701  sub removeuserfile { Line 1738  sub removeuserfile {
         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {          if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
             my $metafile = $fname.'.meta';              my $metafile = $fname.'.meta';
             my $metaresult = &removeuserfile($docuname,$docudom,$metafile);               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
             my ($group,$file);      my $url = "/uploaded/$docudom/$docuname/$fname";
             if ($fname =~ /^groups\/(\w+)\/portfolio(\/.+)$/) {              my ($file,$group) = (&parse_portfolio_url($url))[3,4];
                 $group = $1;  
                 $file = $2;  
             } elsif ($fname =~ /^portfolio(\/.+)$/) {  
                 $file = $1;  
             }  
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$group.$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
                                         'delete');                                          'delete');
         }          }
Line 1734  sub renameuserfile { Line 1766  sub renameuserfile {
             my $newmeta = $new.'.meta';              my $newmeta = $new.'.meta';
             my $metaresult =               my $metaresult = 
                 &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);                  &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
             my ($group,$file);      my $url = "/uploaded/$docudom/$docuname/$old";
             if ($old =~ /^groups\/(\w+)\/portfolio(\/.+)$/) {              my ($file,$group) = (&parse_portfolio_url($url))[3,4];
                 $group = $1;  
                 $file = $2;  
             } elsif ($old =~ /^portfolio(\/.+)$/) {  
                 $file = $1;  
             }  
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$group.$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
                                         'delete');                                          'delete');
         }          }
Line 3439  sub get_portfolio_access { Line 3466  sub get_portfolio_access {
             }              }
             if (@users > 0) {              if (@users > 0) {
                 foreach my $userkey (@users) {                  foreach my $userkey (@users) {
                     if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {                      if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
                         return 'ok';                          foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
                     }                              if (ref($item) eq 'HASH') {
                                   if (($item->{'uname'} eq $env{'user.name'}) &&
                                       ($item->{'udom'} eq $env{'user.domain'})) {
                                       return 'ok';
                                   }
                               }
                           }
                       } 
                 }                  }
             }              }
             my %roleshash;              my %roleshash;
Line 3559  sub parse_portfolio_url { Line 3593  sub parse_portfolio_url {
   
     my ($type,$udom,$unum,$group,$file_name);      my ($type,$udom,$unum,$group,$file_name);
           
     if ($url =~  m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {      if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
  $type = 1;   $type = 1;
         $udom = $1;          $udom = $1;
         $unum = $2;          $unum = $2;
         $file_name = $3;          $file_name = $3;
     } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {      } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
  $type = 2;   $type = 2;
         $udom = $1;          $udom = $1;
         $unum = $2;          $unum = $2;
Line 7151  sub repcopy_userfile { Line 7185  sub repcopy_userfile {
     } else {      } else {
  my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     my $ua=new LWP::UserAgent;      return -1;
     my $request=new HTTP::Request('GET',&tokenwrapper($uri));  
     my $response=$ua->request($request);  
     if ($response->is_success()) {  
  $info=$response->content;  
     } else {  
  return -1;  
     }  
  }   }
  my @parts = ($cdom,$cnum);    my @parts = ($cdom,$cnum); 
  if ($filename =~ m|^(.+)/[^/]+$|) {   if ($filename =~ m|^(.+)/[^/]+$|) {
Line 7312  sub current_machine_ids { Line 7339  sub current_machine_ids {
     return @ids;      return @ids;
 }  }
   
   sub additional_machine_domains {
       my @domains;
       open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
       while( my $line = <$fh>) {
           $line =~ s/\s//g;
           push(@domains,$line);
       }
       return @domains;
   }
   
   sub default_login_domain {
       my $domain = $perlvar{'lonDefDomain'};
       my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
       foreach my $posdom (&current_machine_domains(),
                           &additional_machine_domains()) {
           if (lc($posdom) eq lc($testdomain)) {
               $domain=$posdom;
               last;
           }
       }
       return $domain;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Removed from v.1.822  
changed lines
  Added in v.1.824.2.5

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