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

Diff for /loncom/LONCAPA.pm between versions 1.13.2.1 and 1.15

version 1.13.2.1, 2006/10/13 19:11:05 version 1.15, 2006/11/27 16:34:38
Line 38  use POSIX; Line 38  use POSIX;
   
 my $loncapa_max_wait_time = 13;  my $loncapa_max_wait_time = 13;
   
   
   use vars qw($match_domain   $match_not_domain
       $match_username $match_not_username
       $match_handle   $match_not_handle);
   
 require Exporter;  require Exporter;
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(&add_get_param &escape &unescape &tie_domain_hash &untie_domain_hash &tie_user_hash &untie_user_hash &propath);  our @EXPORT = qw(&add_get_param    &escape            &unescape       
    &tie_domain_hash  &untie_domain_hash &tie_user_hash
    &untie_user_hash  &propath);
   our @EXPORT_OK = qw($match_domain   $match_not_domain
       $match_username $match_not_username
       $match_handle   $match_not_handle);
   our %EXPORT_TAGS = ( 'match' =>[qw($match_domain   $match_not_domain
      $match_username $match_not_username
      $match_handle   $match_not_handle)],);
 my %perlvar;  my %perlvar;
   
   
Line 83  sub unescape { Line 96  sub unescape {
     return $str;      return $str;
 }  }
   
   $match_domain     = $LONCAPA::domain_re     = qr{[\w\-.]+};
   $match_not_domain = $LONCAPA::not_domain_re = qr{[^\w\-.]+};
   sub clean_domain {
       my ($domain) = @_;
       $domain =~ s/$match_not_domain//g;
       return $domain;
   }
   
   sub split_courseid {
       my ($courseid) = @_;
       my  ($domain,$coursenum) = 
    ($courseid=~m{^/($match_domain)/($match_username)});
       return ($domain,$coursenum);
   }
   
   $match_username     = $LONCAPA::username_re     = qr{[\w\-.]+};
   $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+};
   sub clean_username {
       my ($username) = @_;
       $username =~ s/$match_not_username//g;
       return $username;
   }
   
   $match_handle     = $LONCAPA::handle_re     = qr{[\w\-.]+};
   $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.]+};
   sub clean_handle {
       my ($handle) = @_;
       $handle =~ s/$match_not_handle//g;
       return $handle;
   }
   
 # -------------------------------------------- Return path to profile directory  # -------------------------------------------- Return path to profile directory
   
 sub propath {  sub propath {
     my ($udom,$uname)=@_;      my ($udom,$uname)=@_;
     $udom=~s/\W//g;      $udom = &clean_domain($udom);
     $uname=~s/\W//g;      $uname= &clean_username($uname);
     my $subdir=$uname.'__';      my $subdir=$uname.'__';
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";      my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
Line 122  sub tie_domain_hash { Line 166  sub tie_domain_hash {
           
     # Filter out any whitespace in the domain name:      # Filter out any whitespace in the domain name:
           
     $domain =~ s/\W//g;      $domain = &clean_domain($domain);
           
     # We have enough to go on to tie the hash:      # We have enough to go on to tie the hash:
           
Line 157  sub untie_domain_hash { Line 201  sub untie_domain_hash {
 sub tie_user_hash {  sub tie_user_hash {
     my ($domain,$user,$namespace,$how,$loghead,$what) = @_;      my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
   
     $namespace=~s/\//\_/g; # / -> _      $namespace=~s{/}{_}g; # / -> _
     $namespace=~s/\W//g; # whitespace eliminated.      $namespace     = &clean_username($namespace);
     my $proname     = &propath($domain, $user);      my $proname    = &propath($domain, $user);
   
     my $file_prefix="$proname/$namespace";      my $file_prefix="$proname/$namespace";
     return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);      return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
 }  }
Line 269  sub _do_hash_untie { Line 312  sub _do_hash_untie {
        return undef;          return undef; 
    }      } 
 # If this is compressed, we will actually need an exclusive lock  # If this is compressed, we will actually need an exclusive lock
    if (-e "$file_prefix.db.gz"     if (-e "$file_prefix.db.gz") {
        || !-e "$file_prefix.db.old" ) {  
        if (!&flock_sym(LOCK_EX)) {         if (!&flock_sym(LOCK_EX)) {
    &clean_sym();     &clean_sym();
    return undef;     return undef;
Line 295  sub _do_hash_untie { Line 337  sub _do_hash_untie {
        system("gunzip $file_prefix.hist.gz");         system("gunzip $file_prefix.hist.gz");
    }     }
        }         }
        if (!-e "$file_prefix.db.old") {  
            my $dump_db = '/home/httpd/perl/debug/dump_db_static_32';  
    my $create_db = '/home/httpd/perl/debug/create_db_dynamic_64';  
            my $file = "$file_prefix.db";  
            &main::logthis("Converting $file");  
            if (!-x $dump_db) {  
        &clean_symb();  
        &main::logthis("$dump_db unexecutable");  
        return;  
    }  
            if (!-x $create_db) {  
        &clean_symb();  
        &main::logthis("$create_db unexecutable");  
        return;  
    }  
    system("$dump_db -f $file|$create_db -f $file.new");  
    if (!-e "$file.new") {  
        &clean_symb();  
        &main::logthis("conversion faile $file.new doesn't exist");  
        return;  
    }  
            rename($file,"$file.old");  
    rename("$file.new","$file");  
        }  
 # Change access mode to non-blocking  # Change access mode to non-blocking
        $how=$how|&GDBM_NOLOCK();         $how=$how|&GDBM_NOLOCK();
 # Go ahead and tie the hash  # Go ahead and tie the hash
Removed from v.1.13.2.1  
changed lines
  Added in v.1.15

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.