[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.1017 and 1.1035

version 1.1017, 2009/08/15 00:25:53 version 1.1035, 2009/10/24 03:24:25
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 784  sub changepass { Line 785  sub changepass {
     my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;      my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
     $currentpass = &escape($currentpass);      $currentpass = &escape($currentpass);
     $newpass     = &escape($newpass);      $newpass     = &escape($newpass);
     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",      my $lonhost = $perlvar{'lonHostID'};
       my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
        $server);         $server);
     if (! $answer) {      if (! $answer) {
  &logthis("No reply on password change request to $server ".   &logthis("No reply on password change request to $server ".
Line 809  sub changepass { Line 811  sub changepass {
     } elsif ($answer =~ "^refused") {      } elsif ($answer =~ "^refused") {
  &logthis("$server refused to change $uname in $udom password because ".   &logthis("$server refused to change $uname in $udom password because ".
  "it was sent an unencrypted request to change the password.");   "it was sent an unencrypted request to change the password.");
       } elsif ($answer =~ "invalid_client") {
           &logthis("$server refused to change $uname in $udom password because ".
                    "it was a reset by e-mail originating from an invalid server.");
     }      }
     return $answer;      return $answer;
 }  }
Line 958  sub idput { Line 963  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 1051  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 2064  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 2312  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 3071  sub courseidput { Line 3031  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,$catfilter,$showhidden,$caller,$cloner,$cc_clone,$cloneonly)=@_;          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
           $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 3091  sub courseiddump { Line 3052  sub courseiddump {
                          ':'.&escape($regexp_ok).':'.$as_hash.':'.                           ':'.&escape($regexp_ok).':'.$as_hash.':'.
                          &escape($selfenrollonly).':'.&escape($catfilter).':'.                           &escape($selfenrollonly).':'.&escape($catfilter).':'.
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.                           $showhidden.':'.$caller.':'.&escape($cloner).':'.
                          &escape($cc_clone).':'.$cloneonly,$tryserver);                           &escape($cc_clone).':'.$cloneonly.':'.
                            &escape($createdbefore).':'.&escape($createdafter).':'.
                            &escape($creationcontext),$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 3146  sub dcmaildump { Line 3109  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 3839  sub privileged { Line 3802  sub privileged {
     my ($username,$domain)=@_;      my ($username,$domain)=@_;
     my $rolesdump=&reply("dump:$domain:$username:roles",      my $rolesdump=&reply("dump:$domain:$username:roles",
  &homeserver($username,$domain));   &homeserver($username,$domain));
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
           ($rolesdump =~ /^error:/)) {
           return 0;
       }
     my $now=time;      my $now=time;
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
         foreach my $entry (split(/&/,$rolesdump)) {          foreach my $entry (split(/&/,$rolesdump)) {
Line 3867  sub privileged { Line 3833  sub privileged {
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
     my %userroles;      my $now=time;
       my %userroles = ('user.login.time' => $now);
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
           ($rolesdump =~ /^error:/)) { 
           return \%userroles;
       }
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();   
     my $now=time;  
     %userroles = ('user.login.time' => $now);  
     my $group_privs;      my $group_privs;
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
Line 4047  sub role_status { Line 4015  sub role_status {
             $$tstatus='is';              $$tstatus='is';
             if ($$tstart && $$tstart>$then) {              if ($$tstart && $$tstart>$then) {
                 $$tstatus='future';                  $$tstatus='future';
                 if ($$tstart && $$tstart>$refresh) {                  if ($$tstart<$now) {
                     if ($$tstart<$now) {                      if ($$tstart && $$tstart>$refresh) {
                         if (($$where ne '') && ($$role ne '')) {                          if (($$where ne '') && ($$role ne '')) {
                             my (%allroles,%allgroups,$group_privs);                              my (%allroles,%allgroups,$group_privs);
                             my %userroles = (                              my %userroles = (
Line 4078  sub role_status { Line 4046  sub role_status {
                             my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);                              my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
                             &appenv(\%userroles,[$$role,'cm']);                              &appenv(\%userroles,[$$role,'cm']);
                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);                              &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
                             $$tstatus = 'is';  
                         }                          }
                     }                      }
                       $$tstatus = 'is';
                 }                  }
             }              }
             if ($$tend) {              if ($$tend) {
Line 4772  sub usertools_access { Line 4740  sub usertools_access {
         $toolstatus = $env{'environment.'.$context.'.'.$tool};          $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);          my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
         $toolstatus = $userenv{$context.'.'.$tool};          $toolstatus = $userenv{$context.'.'.$tool};
         $inststatus = $userenv{'inststatus'};          $inststatus = $userenv{'inststatus'};
     }      }
Line 4873  sub is_advanced_user { Line 4841  sub is_advanced_user {
     return $is_adv;      return $is_adv;
 }  }
   
   sub check_can_request {
       my ($dom,$can_request) = @_;
       my $canreq = 0;
       my ($types,$typename) = &Apache::loncommon::course_types();
       my @options = ('approval','validate','autolimit');
       my $optregex = join('|',@options);
       if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
           foreach my $type (@{$types}) {
               if (&usertools_access($env{'user.name'},
                                     $env{'user.domain'},
                                     $type,undef,'requestcourses')) {
                   $canreq ++;
                   if ($dom eq $env{'user.domain'}) {
                       $can_request->{$type} = 1;
                   }
               }
               if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
                   my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                   if (@curr > 0) {
                       $canreq ++;
                       unless ($dom eq $env{'user.domain'}) {
                           if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                               $can_request->{$type} = 1;
                           }
                       }
                   }
               }
           }
       }
       return $canreq;
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 5657  sub auto_validate_instcode { Line 5657  sub auto_validate_instcode {
     }      }
     my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.      my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                            &escape($instcode).':'.&escape($owner),$homeserver));                             &escape($instcode).':'.&escape($owner),$homeserver));
     return $response;      my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
       return ($outcome,$description);
 }  }
   
 sub auto_create_password {  sub auto_create_password {
Line 5774  sub auto_instcode_format { Line 5775  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 5882  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 6071  sub assignrole { Line 6103  sub assignrole {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
  unless (&allowed('ccr',$cwosec)) {   unless (&allowed('ccr',$cwosec)) {
            &logthis('Refused custom assignrole: '.             my $refused = 1;
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.             if ($context eq 'requestcourses') {
     $env{'user.name'}.' at '.$env{'user.domain'});                 if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
            return 'refused';                      if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
                          if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
                              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 custom assignrole: '.
                           $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
                           ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
                  return 'refused';
              }
         }          }
         $mrole='cr';          $mrole='cr';
     } elsif ($role =~ /^gr\//) {      } elsif ($role =~ /^gr\//) {
Line 6103  sub assignrole { Line 6152  sub assignrole {
                 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 = '';
                 } elsif ($context eq 'requestcourses') {                  } elsif ($context eq 'requestcourses') {
                     if (($role eq 'cc') && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {                      my @possroles = ('st','ta','ep','in','cc');
                         my ($cdom,$cnum) = ($cwosec =~ m{^/($match_domain)/($match_courseid)$});                      if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
                           my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                         my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                          my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                         if ($crsenv{'internal.courseowner'} eq                           if ($crsenv{'internal.courseowner'} eq 
                              $env{'user.name'}.':'.$env{'user.domain'}) {                               $env{'user.name'}.':'.$env{'user.domain'}) {
Line 6439  sub createcourse { Line 6489  sub createcourse {
         $course_owner,$crstype,$cnum,$context,$category)=@_;          $course_owner,$crstype,$cnum,$context,$category)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      if ($context eq 'requestcourses') {
         if ($context eq 'requestcourses') {          my $can_create = 0;
             unless (&usertools_access($course_owner,$udom,$category,undef,$context)) {          my ($ownername,$ownerdom) = split(':',$course_owner);
                 return 'refused';          if ($udom eq $ownerdom) {
               if (&usertools_access($ownername,$ownerdom,$category,undef,
                                     $context)) {
                   $can_create = 1;
               }
           } else {
               my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
                                              $category);
               if ($userenv{'reqcrsotherdom.'.$category} ne '') {
                   my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
                   if (@curr > 0) {
                       my @options = qw(approval validate autolimit);
                       my $optregex = join('|',@options);
                       if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
                           $can_create = 1;
                       }
                   }
               }
           }
           if ($can_create) {
               unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
                   unless (&allowed('ccc',$udom)) {
                       return 'refused'; 
                   }
             }              }
         } else {          } else {
             return 'refused';              return 'refused';
         }          }
       } elsif (!&allowed('ccc',$udom)) {
           return 'refused';
     }      }
 # --------------------------------------------------------------- Get Unique ID  # --------------------------------------------------------------- Get Unique ID
     my $uname;      my $uname;
Line 6476  sub createcourse { Line 6551  sub createcourse {
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existence  # log existence
       my $now = time;
     my $newcourse = {      my $newcourse = {
                     $udom.'_'.$uname => {                      $udom.'_'.$uname => {
                                      description => $description,                                       description => $description,
                                      inst_code   => $inst_code,                                       inst_code   => $inst_code,
                                      owner       => $course_owner,                                       owner       => $course_owner,
                                      type        => $crstype,                                       type        => $crstype,
                                        creator     => $env{'user.name'}.':'.
                                                       $env{'user.domain'},
                                        created     => $now,
                                        context     => $context,
                                                 },                                                  },
                     };                      };
     &courseidput($udom,$newcourse,$uhome,'notime');      &courseidput($udom,$newcourse,$uhome,'notime');
Line 8175  sub symbverify { Line 8255  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
           if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
               $thisurl =~ s/\?.+$//;
           }
         my $ids=$bighash{'ids_'.&clutter($thisurl)};          my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {           unless ($ids) { 
            $ids=$bighash{'ids_/'.$thisurl};             $ids=$bighash{'ids_/'.$thisurl};
Line 8183  sub symbverify { Line 8266  sub symbverify {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
     foreach my $id (split(/\,/,$ids)) {      foreach my $id (split(/\,/,$ids)) {
        my ($mapid,$resid)=split(/\./,$id);         my ($mapid,$resid)=split(/\./,$id);
                  if ($thisfn =~ m{^/adm/wrapper/ext/}) {
                      $symb =~ s/\?.+$//;
                  }
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
Line 9059  sub declutter { Line 9145  sub declutter {
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
     $thisfn=~s/\?.+$//;      unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
           $thisfn=~s/\?.+$//;
       }
     return $thisfn;      return $thisfn;
 }  }
   
Line 9071  sub clutter { Line 9159  sub clutter {
  || $thisfn =~ m{^/adm/(includes|pages)} ) {    || $thisfn =~ m{^/adm/(includes|pages)} ) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
     if ($thisfn !~m|/adm|) {      if ($thisfn !~m|^/adm|) {
  if ($thisfn =~ m|/ext/|) {   if ($thisfn =~ m|^/ext/|) {
     $thisfn='/adm/wrapper'.$thisfn;      $thisfn='/adm/wrapper'.$thisfn;
  } else {   } else {
     my ($ext) = ($thisfn =~ /\.(\w+)$/);      my ($ext) = ($thisfn =~ /\.(\w+)$/);
Removed from v.1.1017  
changed lines
  Added in v.1.1035

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