[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.1015 and 1.1024

version 1.1015, 2009/08/14 17:35:08 version 1.1024, 2009/08/28 19:43:10
Line 92  use Time::HiRes qw( gettimeofday tv_inte Line 92  use Time::HiRes qw( gettimeofday tv_inte
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
   use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
Line 958  sub idput { Line 959  sub idput {
     }      }
 }  }
   
 # ------------------------------------------------ dump from domain db files  # ------------------------------dump from db file owned by domainconfig user
   
 sub dump_dom {  sub dump_dom {
     my ($namespace,$udom,$uhome,$regexp,$range)=@_;      my ($namespace,$udom,$regexp,$range)=@_;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
         if (defined(&domain($udom,'primary'))) {  
             $uhome=&domain($udom,'primary');  
         } else {  
             undef($uhome);  
         }  
     } else {  
         if (!$uhome) {  
             if (defined(&domain($udom,'primary'))) {  
                 $uhome=&domain($udom,'primary');  
             }  
         }  
     }      }
     my %returnhash;      my %returnhash;
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom) {
         if ($regexp) {          my $uname = &get_domainconfiguser($udom);
             $regexp=&escape($regexp);          %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
         } else {  
             $regexp='.';  
         }  
         my $rep=&reply("dumpdom:$udom:$namespace:$regexp:$range",$uhome);  
         my @pairs=split(/\&/,$rep);  
         foreach my $item (@pairs) {  
             my ($key,$value)=split(/=/,$item,2);  
             $key = &unescape($key);  
             next if ($key =~ /^error: 2 /);  
             $returnhash{$key}=&thaw_unescape($value);  
         }  
     }      }
     return %returnhash;      return %returnhash;
 }  }
   
 # ------------------------------------------- get items from domain db files     # ------------------------------------------ get items from domain db files   
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
Line 1069  sub put_dom { Line 1047  sub put_dom {
     }      }
 }  }
   
 # -------------------------------------- newput for items in domain db files  # --------------------- newput for items in db file owned by domainconfig user
   
 sub newput_dom {  sub newput_dom {
     my ($namespace,$storehash,$udom,$uhome) = @_;      my ($namespace,$storehash,$udom) = @_;
     my $result;      my $result;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
         if (defined(&domain($udom,'primary'))) {  
             $uhome=&domain($udom,'primary');  
         } else {  
             undef($uhome);  
         }  
     } else {  
         if (!$uhome) {  
             if (defined(&domain($udom,'primary'))) {  
                 $uhome=&domain($udom,'primary');  
             }  
         }  
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom) {
         my $items='';          my $uname = &get_domainconfiguser($udom);
         if (ref($storehash) eq 'HASH') {          $result = &newput($namespace,$storehash,$udom,$uname);
             foreach my $key (keys(%$storehash)) {  
                 $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';  
             }  
             $items=~s/\&$//;  
             $result = &reply("newputdom:$udom:$namespace:$items",$uhome);  
         }  
     } else {  
         &logthis("put_dom failed - no homeserver and/or domain");  
     }      }
     return $result;      return $result;
 }  }
   
   # --------------------- delete for items in db file owned by domainconfig user
 sub del_dom {  sub del_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom)=@_;
     if (ref($storearr) eq 'ARRAY') {      if (ref($storearr) eq 'ARRAY') {
         my $items='';  
         foreach my $item (@$storearr) {  
             $items.=&escape($item).'&';  
         }  
         $items=~s/\&$//;  
         if (!$udom) {          if (!$udom) {
             $udom=$env{'user.domain'};              $udom=$env{'user.domain'};
             if (defined(&domain($udom,'primary'))) {  
                 $uhome=&domain($udom,'primary');  
             } else {  
                 undef($uhome);  
             }  
         } else {  
             if (!$uhome) {  
                 if (defined(&domain($udom,'primary'))) {  
                     $uhome=&domain($udom,'primary');  
                 }  
             }  
         }          }
         if ($udom && $uhome && ($uhome ne 'no_host')) {          if ($udom) {
             return &reply("deldom:$udom:$namespace:$items",$uhome);              my $uname = &get_domainconfiguser($udom); 
         } else {              return &del($namespace,$storearr,$udom,$uname);
             &logthis("del_dom failed - no homeserver and/or domain");  
         }          }
     }      }
 }  }
   
   # ----------------------------------construct domainconfig user for a domain 
   sub get_domainconfiguser {
       my ($udom) = @_;
       return $udom.'-domainconfig';
   }
   
 sub retrieve_inst_usertypes {  sub retrieve_inst_usertypes {
     my ($udom) = @_;      my ($udom) = @_;
     my (%returnhash,@order);      my (%returnhash,@order);
Line 2112  sub process_coursefile { Line 2060  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 $mm = new File::MMagic;
                 unless ($parse_result eq 'ok') {                  my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);                  if ($mime_type eq 'text/html') {
                       my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
                       unless ($parse_result eq 'ok') {
                           &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                       }
                 }                  }
             }              }
             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
Line 2356  sub finishuserfileupload { Line 2308  sub finishuserfileupload {
  }   }
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,          my $mm = new File::MMagic;
    $codebase);          my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
         unless ($parse_result eq 'ok') {          if ($mime_type eq 'text/html') {
             &logthis('Failed to parse '.$filepath.$file.              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
      ' for embedded media: '.$parse_result);                                                          $allfiles,$codebase);
               unless ($parse_result eq 'ok') {
                   &logthis('Failed to parse '.$filepath.$file.
              ' for embedded media: '.$parse_result); 
               }
         }          }
     }      }
     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
Line 3146  sub dcmaildump { Line 3102  sub dcmaildump {
   
 sub get_domain_roles {  sub get_domain_roles {
     my ($dom,$roles,$startdate,$enddate)=@_;      my ($dom,$roles,$startdate,$enddate)=@_;
     if (undef($startdate) || $startdate eq '') {      if ((!defined($startdate)) || ($startdate eq '')) {
         $startdate = '.';          $startdate = '.';
     }      }
     if (undef($enddate) || $enddate eq '') {      if ((!defined($enddate)) || ($enddate eq '')) {
         $enddate = '.';          $enddate = '.';
     }      }
     my $rolelist;      my $rolelist;
Line 5774  sub auto_instcode_format { Line 5730  sub auto_instcode_format {
  push(@homeservers,$tryserver);   push(@homeservers,$tryserver);
     }      }
         }          }
       } elsif ($caller eq 'requests') {
           if ($codedom =~ /^$match_domain$/) {
               my $chome = &domain($codedom,'primary');
               unless ($chome eq 'no_host') {
                   push(@homeservers,$chome);
               }
           }
     } else {      } else {
         push(@homeservers,&homeserver($caller,$codedom));          push(@homeservers,&homeserver($caller,$codedom));
     }      }
Line 5874  sub auto_possible_instcodes { Line 5837  sub auto_possible_instcodes {
   
 sub auto_courserequest_checks {  sub auto_courserequest_checks {
     my ($dom) = @_;      my ($dom) = @_;
     my %validations;      my ($homeserver,%validations);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {
           my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $validations{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
     return %validations;       return %validations; 
 }  }
   
 sub auto_courserequest_validation {  sub auto_courserequest_validation {
     my ($dom,$details,$inststatuses,$message) = @_;      my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
     return 'pending';      my ($homeserver,$response);
       if ($dom =~ /^$match_domain$/) {
           $homeserver = &domain($dom,'primary');
       }
       unless ($homeserver eq 'no_host') {  
             
           $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                       ':'.&escape($crstype).':'.&escape($inststatuslist).
                                       ':'.&escape($instcode).':'.&escape($instseclist),
                                       $homeserver));
       }
       return $response;
 }  }
   
 sub auto_validate_class_sec {  sub auto_validate_class_sec {
Line 6102  sub assignrole { Line 6089  sub assignrole {
             if ($refused) {              if ($refused) {
                 if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {                  if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                     $refused = '';                      $refused = '';
                 } else {                  } elsif ($context eq 'requestcourses') {
                       if (($role eq 'cc') && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
                           my ($cdom,$cnum) = ($cwosec =~ m{^/($match_domain)/($match_courseid)$});
                           my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                           if ($crsenv{'internal.courseowner'} eq 
                                $env{'user.name'}.':'.$env{'user.domain'}) {
                               $refused = '';
                           }
                       }
                   }
                   if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
                              ' '.$role.' '.$end.' '.$start.' by '.                               ' '.$role.' '.$end.' '.$start.' by '.
                $env{'user.name'}.' at '.$env{'user.domain'});                 $env{'user.name'}.' at '.$env{'user.domain'});
Line 6426  sub writecoursepref { Line 6423  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
         $course_owner,$crstype,$cnum)=@_;          $course_owner,$crstype,$cnum,$context,$category)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
         return 'refused';          if ($context eq 'requestcourses') {
               unless (&usertools_access($course_owner,$udom,$category,undef,$context)) {
                   return 'refused';
               }
           } else {
               return 'refused';
           }
     }      }
 # --------------------------------------------------------------- Get Unique ID  # --------------------------------------------------------------- Get Unique ID
     my $uname;      my $uname;
Line 6532  sub is_course { Line 6535  sub is_course {
 sub store_userdata {  sub store_userdata {
     my ($storehash,$datakey,$namespace,$udom,$uname) = @_;      my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
     my $result;      my $result;
     if $datakey ne '') {      if ($datakey ne '') {
         if (ref($storehash) eq 'HASH') {          if (ref($storehash) eq 'HASH') {
             my $uhome=&homeserver();              if ($udom eq '' || $uname eq '') {
                   $udom = $env{'user.domain'};
                   $uname = $env{'user.name'};
               }
               my $uhome=&homeserver($uname,$udom);
             if (($uhome eq '') || ($uhome eq 'no_host')) {              if (($uhome eq '') || ($uhome eq 'no_host')) {
                 $result = 'error: no_host';                  $result = 'error: no_host';
             } else {              } else {
Removed from v.1.1015  
changed lines
  Added in v.1.1024

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