[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.1008 and 1.1013

version 1.1008, 2009/07/31 02:20:17 version 1.1013, 2009/08/11 01:39:44
Line 958  sub idput { Line 958  sub idput {
     }      }
 }  }
   
   # ------------------------------------------------ dump from domain db files
   
   sub dump_dom {
       my ($namespace,$udom,$uhome,$regexp,$range)=@_;
       if (!$udom) {
           $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;
       if ($udom && $uhome && ($uhome ne 'no_host')) {
           if ($regexp) {
               $regexp=&escape($regexp);
           } 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;
   }
   
 # ------------------------------------------- get items from domain db files     # ------------------------------------------- get items from domain db files   
   
 sub get_dom {  sub get_dom {
Line 1032  sub put_dom { Line 1069  sub put_dom {
     }      }
 }  }
   
   # -------------------------------------- newput for items in domain db files
   
   sub newput_dom {
       my ($namespace,$storehash,$udom,$uhome) = @_;
       my $result;
       if (!$udom) {
           $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')) {
           my $items='';
           if (ref($storehash) eq 'HASH') {
               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;
   }
   
   sub del_dom {
       my ($namespace,$storearr,$udom,$uhome)=@_;
       if (ref($storearr) eq 'ARRAY') {
           my $items='';
           foreach my $item (@$storearr) {
               $items.=&escape($item).'&';
           }
           $items=~s/\&$//;
           if (!$udom) {
               $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')) {
               return &reply("deldom:$udom:$namespace:$items",$uhome);
           } else {
               &logthis("del_dom failed - no homeserver and/or domain");
           }
       }
   }
   
 sub retrieve_inst_usertypes {  sub retrieve_inst_usertypes {
     my ($udom) = @_;      my ($udom) = @_;
     my (%returnhash,@order);      my (%returnhash,@order);
Line 1665  sub userenvironment { Line 1766  sub userenvironment {
     }      }
     $items=~s/\&$//;      $items=~s/\&$//;
     my %returnhash=();      my %returnhash=();
     my @answer=split(/\&/,      my $uhome = &homeserver($unam,$udom);
                 &reply('get:'.$udom.':'.$unam.':environment:'.$items,      unless ($uhome eq 'no_host') {
                       &homeserver($unam,$udom)));          my @answer=split(/\&/, 
     my $i;              &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
     for ($i=0;$i<=$#what;$i++) {          my $i;
  $returnhash{$what[$i]}=&unescape($answer[$i]);          for ($i=0;$i<=$#what;$i++) {
       $returnhash{$what[$i]}=&unescape($answer[$i]);
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 5769  sub auto_possible_instcodes { Line 5872  sub auto_possible_instcodes {
     return $response;      return $response;
 }  }
   
   sub auto_courserequest_checks {
       my ($dom) = @_;
       my %validations;
       return %validations; 
   }
   
   sub auto_courserequest_validation {
       my ($dom,$details,$inststatuses,$message) = @_;
       return 'pending';
   }
   
 sub auto_validate_class_sec {  sub auto_validate_class_sec {
     my ($cdom,$cnum,$owners,$inst_class) = @_;      my ($cdom,$cnum,$owners,$inst_class) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
Line 6312  sub writecoursepref { Line 6426  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)=@_;          $course_owner,$crstype,$cnum)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
         return 'refused';          return 'refused';
     }      }
 # ------------------------------------------------------------------- Create ID  # --------------------------------------------------------------- Get Unique ID
    my $uname=int(1+rand(9)).      my $uname;
        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].      if ($cnum =~ /^$match_courseid$/) {
        substr($$.time,0,5).unpack("H8",pack("I32",time)).          my $chome=&homeserver($cnum,$udom,'true');
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};          if (($chome eq '') || ($chome eq 'no_host')) {
 # ----------------------------------------------- Make sure that does not exist              $uname = $cnum;
    my $uhome=&homeserver($uname,$udom,'true');          } else {
    unless (($uhome eq '') || ($uhome eq 'no_host')) {              $uname = &generate_coursenum($udom);
        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).          }
         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};      } else {
        $uhome=&homeserver($uname,$udom,'true');                 $uname = &generate_coursenum($udom);
        unless (($uhome eq '') || ($uhome eq 'no_host')) {      }
            return 'error: unable to generate unique course-ID';      return $uname if ($uname =~ /^error/);
        }   # -------------------------------------------------- Check supplied server name
    }  
 # ------------------------------------------------ Check supplied server name  
     $course_server = $env{'user.homeserver'} if (! defined($course_server));      $course_server = $env{'user.homeserver'} if (! defined($course_server));
     if (! &is_library($course_server)) {      if (! &is_library($course_server)) {
         return 'error:bad server name '.$course_server;          return 'error:bad server name '.$course_server;
Line 6342  sub createcourse { Line 6454  sub createcourse {
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $course_server);                        $course_server);
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
Line 6383  ENDINITMAP Line 6495  ENDINITMAP
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
   # ------------------------------------------------------------------- Create ID
   sub generate_coursenum {
       my ($udom) = @_;
       my $domdesc = &domain($udom);
       return 'error: invalid domain' if ($domdesc eq '');
       my $uname=int(1+rand(9)).
           ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
           substr($$.time,0,5).unpack("H8",pack("I32",time)).
           unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
   # ----------------------------------------------- Make sure that does not exist
       my $uhome=&homeserver($uname,$udom,'true');
       unless (($uhome eq '') || ($uhome eq 'no_host')) {
           $uname=int(1+rand(9)).
                  ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
                  substr($$.time,0,5).unpack("H8",pack("I32",time)).
                  unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
           $uhome=&homeserver($uname,$udom,'true');
           unless (($uhome eq '') || ($uhome eq 'no_host')) {
               return 'error: unable to generate unique course-ID';
           }
       }
       return $uname;
   }
   
 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,
Line 6393  sub is_course { Line 6529  sub is_course {
     return 0;      return 0;
 }  }
   
   sub store_coursereq {
       my ($requestkey,$storehash) = @_;
       my $result;
       if ($requestkey =~ /^($match_domain)_($match_courseid)$/) {
           if (ref($storehash) eq 'HASH') {
               my $namespace = 'courserequests';
               my $uhome=&homeserver();
               if (($uhome eq '') || ($uhome eq 'no_host')) {
                   $result = 'error: no_host';
               } else {
                   $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
                   $storehash->{'host'} = $perlvar{'lonHostID'};
   
                   my $namevalue='';
                   foreach my $key (keys(%{$storehash})) {
                       $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                   }
                   $namevalue=~s/\&$//;
                   $result =  &reply("store:$env{'user.domain'}:$env{'user.name'}:".
                                     "$namespace:$requestkey:$namevalue",$uhome);
               }
           } else {
               $result = 'error: data to store was not a hash reference'; 
           }
       } else {
           $result= 'error: invalid requestkey'; 
       }
       return $result;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
Line 9905  database) for a course Line 10071  database) for a course
   
 =item *  =item *
   
 createcourse($udom,$description,$url) : make/modify course  createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
   
   =item *
   
   generate_coursenum($udom) : get a unique (unused) course number in domain $udom
   
 =back  =back
   
Removed from v.1.1008  
changed lines
  Added in v.1.1013

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