[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.1035 and 1.1040

version 1.1035, 2009/10/24 03:24:25 version 1.1040, 2009/10/31 23:37:00
Line 4842  sub is_advanced_user { Line 4842  sub is_advanced_user {
 }  }
   
 sub check_can_request {  sub check_can_request {
     my ($dom,$can_request) = @_;      my ($dom,$can_request,$request_domains) = @_;
     my $canreq = 0;      my $canreq = 0;
     my ($types,$typename) = &Apache::loncommon::course_types();      my ($types,$typename) = &Apache::loncommon::course_types();
     my @options = ('approval','validate','autolimit');      my @options = ('approval','validate','autolimit');
Line 4853  sub check_can_request { Line 4853  sub check_can_request {
                                   $env{'user.domain'},                                    $env{'user.domain'},
                                   $type,undef,'requestcourses')) {                                    $type,undef,'requestcourses')) {
                 $canreq ++;                  $canreq ++;
                   if (ref($request_domains) eq 'HASH') {
                       push(@{$request_domains->{$type}},$env{'user.domain'});
                   }
                 if ($dom eq $env{'user.domain'}) {                  if ($dom eq $env{'user.domain'}) {
                     $can_request->{$type} = 1;                      $can_request->{$type} = 1;
                 }                  }
Line 4860  sub check_can_request { Line 4863  sub check_can_request {
             if ($env{'environment.reqcrsotherdom.'.$type} ne '') {              if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
                 my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});                  my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                 if (@curr > 0) {                  if (@curr > 0) {
                     $canreq ++;                      foreach my $item (@curr) {
                     unless ($dom eq $env{'user.domain'}) {                          if (ref($request_domains) eq 'HASH') {
                               my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
                               if ($otherdom ne '') {
                                   if (ref($request_domains->{$type}) eq 'ARRAY') {
                                       unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
                                           push(@{$request_domains->{$type}},$otherdom);
                                       }
                                   } else {
                                       push(@{$request_domains->{$type}},$otherdom);
                                   }
                               }
                           }
                       }
                       unless($dom eq $env{'user.domain'}) {
                           $canreq ++;
                         if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {                          if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                             $can_request->{$type} = 1;                              $can_request->{$type} = 1;
                         }                          }
Line 5027  sub allowed { Line 5044  sub allowed {
     my $statecond=0;      my $statecond=0;
     my $courseprivid='';      my $courseprivid='';
   
       my $ownaccess;
       # Community Coordinator browsing resource space.
       if (($priv eq 'bro') && ($env{'user.author'})) {
           if ($uri eq '') {
               $ownaccess = 1;
           } else {
               if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
                   my $udom = $env{'user.domain'};
                   my $uname = $env{'user.name'};
                   if ($uri =~ m{^\Q$udom\E/?$}) {
                       $ownaccess = 1;
                   } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) {
                       unless ($uri =~ m{\.\./}) {
                           $ownaccess = 1;
                       }
                   } elsif (($udom ne 'public') && ($uname ne 'public')) {
                       my $now = time;
                       if ($uri =~ m{^([^/]+)/?$}) {
                           my $adom = $1;
                           foreach my $key (keys(%env)) {
                               if ($key =~ m{^user\.role\.ca/\Q$adom\E}) {
                                   my ($start,$end) = split('.',$env{$key});
                                   if (($now >= $start) && (!$end || $end < $now)) {
                                       $ownaccess = 1;
                                       last;
                                   }
                               }
                           }
                       } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) {
                           my $adom = $1;
                           my $aname = $2;
                           if ($env{"user.role.ca./$adom/$aname"}) {
                               my ($start,$end) =
                                   split('.',$env{"user.role.ca./$adom/$aname"});
                               if (($now >= $start) && (!$end || $end < $now)) {
                                   $ownaccess = 1;
                               }
                           }
                       }
                   }
               }
           }
       }
   
 # Course  # Course
   
     if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {      if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro' && !$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # Domain  # Domain
   
     if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}      if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro' && !$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # Course: uri itself is a course  # Course: uri itself is a course
Line 5047  sub allowed { Line 5112  sub allowed {
   
     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}      if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
        $thisallowed.=$1;          unless (($priv eq 'bro' && !$ownaccess)) {
               $thisallowed.=$1;
           }
     }      }
   
 # URI is an uploaded document for this course, default permissions don't matter  # URI is an uploaded document for this course, default permissions don't matter
Line 6073  sub plaintext { Line 6140  sub plaintext {
     if (!defined($cid)) {      if (!defined($cid)) {
         $cid = $env{'request.course.id'};          $cid = $env{'request.course.id'};
     }      }
     if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) {  
         unless ($forcedefault) {  
             my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};   
             &Apache::lonlocal::mt_escape(\$roletext);  
             return &Apache::lonlocal::mt($roletext);  
         }  
     }  
     my %rolenames = (      my %rolenames = (
                       Course    => 'std',                        Course    => 'std',
                       Community => 'alt1',                        Community => 'alt1',
                     );                      );
     if (defined($type) &&       if ($cid ne '') {
          defined($rolenames{$type}) &&           if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
          defined($prp{$short}{$rolenames{$type}})) {              unless ($forcedefault) {
                   my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; 
                   &Apache::lonlocal::mt_escape(\$roletext);
                   return &Apache::lonlocal::mt($roletext);
               }
           }
       }
       if ((defined($type)) && (defined($rolenames{$type})) &&
           (defined($rolenames{$type})) && 
           (defined($prp{$short}{$rolenames{$type}}))) {
         return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});          return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
     } else {      } elsif ($cid ne '') {
         return &Apache::lonlocal::mt($prp{$short}{'std'});          my $crstype = $env{'course.'.$cid.'.type'};
           if (($crstype ne '') && (defined($rolenames{$crstype})) &&
               (defined($prp{$short}{$rolenames{$crstype}}))) {
               return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}});
           }
     }      }
       return &Apache::lonlocal::mt($prp{$short}{'std'});
 }  }
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
Line 6530  sub createcourse { Line 6604  sub createcourse {
         if (($chome eq '') || ($chome eq 'no_host')) {          if (($chome eq '') || ($chome eq 'no_host')) {
             $uname = $cnum;              $uname = $cnum;
         } else {          } else {
             $uname = &generate_coursenum($udom);              $uname = &generate_coursenum($udom,$crstype);
         }          }
     } else {      } else {
         $uname = &generate_coursenum($udom);          $uname = &generate_coursenum($udom,$crstype);
     }      }
     return $uname if ($uname =~ /^error/);      return $uname if ($uname =~ /^error/);
 # -------------------------------------------------- Check supplied server name  # -------------------------------------------------- Check supplied server name
Line 6593  ENDINITMAP Line 6667  ENDINITMAP
   
 # ------------------------------------------------------------------- Create ID  # ------------------------------------------------------------------- Create ID
 sub generate_coursenum {  sub generate_coursenum {
     my ($udom) = @_;      my ($udom,$crstype) = @_;
     my $domdesc = &domain($udom);      my $domdesc = &domain($udom);
     return 'error: invalid domain' if ($domdesc eq '');      return 'error: invalid domain' if ($domdesc eq '');
     my $uname=int(1+rand(9)).      my $first;
       if ($crstype eq 'Community') {
           $first = '0';
       } else {
           $first = int(1+rand(9)); 
       } 
       my $uname=$first.
         ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].          ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
         substr($$.time,0,5).unpack("H8",pack("I32",time)).          substr($$.time,0,5).unpack("H8",pack("I32",time)).
         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};          unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 # ----------------------------------------------- Make sure that does not exist  # ----------------------------------------------- Make sure that does not exist
     my $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
     unless (($uhome eq '') || ($uhome eq 'no_host')) {      unless (($uhome eq '') || ($uhome eq 'no_host')) {
         $uname=int(1+rand(9)).          if ($crstype eq 'Community') {
               $first = '0';
           } else {
               $first = int(1+rand(9));
           }
           $uname=$first.
                ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].                 ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
                substr($$.time,0,5).unpack("H8",pack("I32",time)).                 substr($$.time,0,5).unpack("H8",pack("I32",time)).
                unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};                 unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
Line 10187  createcourse($udom,$description,$url,$co Line 10272  createcourse($udom,$description,$url,$co
   
 =item *  =item *
   
 generate_coursenum($udom) : get a unique (unused) course number in domain $udom  generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
   
 =back  =back
   
Removed from v.1.1035  
changed lines
  Added in v.1.1040

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