[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.1238 and 1.1250

version 1.1238, 2013/09/02 14:40:18 version 1.1250, 2014/02/23 20:53:03
Line 78  use Image::Magick; Line 78  use Image::Magick;
   
 use Encode;  use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab);
   
Line 356  sub get_remote_globals { Line 356  sub get_remote_globals {
 }  }
   
 sub remote_devalidate_cache {  sub remote_devalidate_cache {
     my ($lonhost,$name,$id) = @_;      my ($lonhost,$cachekeys) = @_;
     my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);      my $items;
       return unless (ref($cachekeys) eq 'ARRAY');
       my $cachestr = join('&',@{$cachekeys});
       my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
     return $response;      return $response;
 }  }
   
Line 603  sub transfer_profile_to_env { Line 606  sub transfer_profile_to_env {
   
 # ---------------------------------------------------- Check for valid session   # ---------------------------------------------------- Check for valid session 
 sub check_for_valid_session {  sub check_for_valid_session {
     my ($r,$name) = @_;      my ($r,$name,$userhashref) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     if ($name eq '') {      if ($name eq '') {
         $name = 'lonID';          $name = 'lonID';
Line 634  sub check_for_valid_session { Line 637  sub check_for_valid_session {
  || !defined($disk_env{'user.domain'})) {   || !defined($disk_env{'user.domain'})) {
  return undef;   return undef;
     }      }
     if (($r->user() eq '') && ($apache >= 2.4)) {  
         if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {      if (ref($userhashref) eq 'HASH') {
             $r->user($disk_env{'user.name'});          $userhashref->{'name'} = $disk_env{'user.name'};
         } else {          $userhashref->{'domain'} = $disk_env{'user.domain'};
             $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});  
         }  
     }      }
   
     return $handle;      return $handle;
 }  }
   
Line 674  sub appenv { Line 676  sub appenv {
     if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {      if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 $refused = 1;                  $refused = 1;
                 if (ref($roles) eq 'ARRAY') {                  if (ref($roles) eq 'ARRAY') {
                     my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);                      my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});
                     if (grep(/^\Q$role\E$/,@{$roles})) {                      if (grep(/^\Q$role\E$/,@{$roles})) {
                         $refused = 0;                          $refused = 0;
                     }                      }
Line 1323  sub check_loadbalancing { Line 1325  sub check_loadbalancing {
             }              }
         }          }
     } elsif (($homeintdom) && ($udom ne $serverhomedom)) {      } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
         my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);          ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
         unless (defined($cached)) {          unless (defined($cached)) {
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);                  &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
Line 1984  sub inst_userrules { Line 1986  sub inst_userrules {
 # ------------- Get Authentication, Language and User Tools Defaults for Domain  # ------------- Get Authentication, Language and User Tools Defaults for Domain
   
 sub get_domain_defaults {  sub get_domain_defaults {
     my ($domain) = @_;      my ($domain,$ignore_cache) = @_;
       return if (($domain eq '') || ($domain eq 'public'));
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
     my ($result,$cached)=&is_cached_new('domdefaults',$domain);      unless ($ignore_cache) {
     if (defined($cached)) {          my ($result,$cached)=&is_cached_new('domdefaults',$domain);
         if (ref($result) eq 'HASH') {          if (defined($cached)) {
             return %{$result};              if (ref($result) eq 'HASH') {
                   return %{$result};
               }
         }          }
     }      }
     my %domdefaults;      my %domdefaults;
Line 2027  sub get_domain_defaults { Line 2032  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial','community') {          foreach my $item ('official','unofficial','community','textbook') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
Line 2044  sub get_domain_defaults { Line 2049  sub get_domain_defaults {
         if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
             $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};              $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
             $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};              $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
               $domdefaults{'textbookcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'textbook'};
         }          }
         if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
             $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};              $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};
             $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};              $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};
             $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};                         $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};
               $domdefaults{'textbookquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'textbook'};
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 3496  sub extract_embedded_items { Line 3503  sub extract_embedded_items {
                     }                      }
                 }                  }
     }      }
               if (lc($tagname) eq 'iframe') {
                   my $src = $attr->{'src'} ;
                   if (($src ne '') && ($src !~ m{^(/|https?://)})) {
                       &add_filetype($allfiles,$src,'src');
                   } elsif ($src =~ m{^/}) {
                       if ($env{'request.course.id'}) {
                           my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                           my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                           my $url = &hreflocation('',$fullpath);
                           if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
                               my $relpath = $1;
                               if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
                                   &add_filetype($allfiles,$1,'src');
                               }
                           }
                       }
                   }
               }
             if ($t->[4] =~ m{/>$}) {              if ($t->[4] =~ m{/>$}) {
                 pop(@state);                    pop(@state);
             }              }
  } elsif ($t->[0] eq 'E') {   } elsif ($t->[0] eq 'E') {
     my ($tagname) = ($t->[1]);      my ($tagname) = ($t->[1]);
Line 4154  sub courseiddump { Line 4179  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,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
           $hasuniquecode)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 4177  sub courseiddump { Line 4203  sub courseiddump {
                                 &escape($catfilter), $showhidden, $caller,                                   &escape($catfilter), $showhidden, $caller, 
                                 &escape($cloner), &escape($cc_clone), $cloneonly,                                   &escape($cloner), &escape($cc_clone), $cloneonly, 
                                 &escape($createdbefore), &escape($createdafter),                                   &escape($createdbefore), &escape($createdafter), 
                                 &escape($creationcontext), $domcloner)));                                  &escape($creationcontext), $domcloner, $hasuniquecode)));
                 } else {                  } else {
                     $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.                      $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                              $sincefilter.':'.&escape($descfilter).':'.                               $sincefilter.':'.&escape($descfilter).':'.
Line 4188  sub courseiddump { Line 4214  sub courseiddump {
                              $showhidden.':'.$caller.':'.&escape($cloner).':'.                               $showhidden.':'.$caller.':'.&escape($cloner).':'.
                              &escape($cc_clone).':'.$cloneonly.':'.                               &escape($cc_clone).':'.$cloneonly.':'.
                              &escape($createdbefore).':'.&escape($createdafter).':'.                               &escape($createdbefore).':'.&escape($createdafter).':'.
                              &escape($creationcontext).':'.$domcloner,                               &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,
                              $tryserver);                               $tryserver);
                 }                  }
                                             
Line 5188  sub set_arearole { Line 5214  sub set_arearole {
 sub custom_roleprivs {  sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
     my $homsvr=homeserver($rauthor,$rdomain);      my $homsvr = &homeserver($rauthor,$rdomain);
     if (&hostname($homsvr) ne '') {      if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=          my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
Line 5309  sub set_userprivs { Line 5335  sub set_userprivs {
   
 sub role_status {  sub role_status {
     my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;      my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
     my @pwhere = ();  
     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {      if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
         (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);          my ($one,$two) = split(m{\./},$rolekey,2);
           (undef,undef,$$role) = split(/\./,$one,3);
           $$where = '/'.$two;
         unless (!defined($$role) || $$role eq '') {          unless (!defined($$role) || $$role eq '') {
             $$where=join('.',@pwhere);  
             $$trolecode=$$role.'.'.$$where;              $$trolecode=$$role.'.'.$$where;
             ($$tstart,$$tend)=split(/\./,$env{$rolekey});              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
             $$tstatus='is';              $$tstatus='is';
Line 6184  sub usertools_access { Line 6210  sub usertools_access {
                       official   => 1,                        official   => 1,
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                         textbook   => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
Line 6199  sub usertools_access { Line 6226  sub usertools_access {
     }      }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
   
     if ((!defined($udom)) || (!defined($uname))) {      if (($udom eq '') || ($uname eq '')) {
         $udom = $env{'user.domain'};          $udom = $env{'user.domain'};
         $uname = $env{'user.name'};          $uname = $env{'user.name'};
     }      }
Line 6709  sub allowed { Line 6736  sub allowed {
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri);   $thisallowed = &portfolio_access($uri);
     }      }
       
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
Line 7824  sub auto_validate_class_sec { Line 7851  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
   sub auto_crsreq_update {
       my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
           $code,$inbound) = @_;
       my ($homeserver,%crsreqresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inbound) eq 'HASH') {
               $info = &freeze_escape($inbound);
           }
           my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
                               ':'.&escape($action).':'.&escape($ownername).':'.
                               &escape($ownerdomain).':'.&escape($fullname).':'.
                               &escape($title).':'.&escape($code).':'.$info,$homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return \%crsreqresponse;
   }
   
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
Line 12109  sub fetch_dns_checksums { Line 12163  sub fetch_dns_checksums {
 }  }
   
 sub all_loncaparevs {  sub all_loncaparevs {
     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);      return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
 }  }
   
 # ---------------------------------------------------------- Read loncaparev table  # ---------------------------------------------------------- Read loncaparev table
Line 12287  $readit=1; Line 12341  $readit=1;
  if ($test != 0) { $_64bit=1; } else { $_64bit=0; }   if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
  &logthis(" Detected 64bit platform ($_64bit)");   &logthis(" Detected 64bit platform ($_64bit)");
     }      }
   
     {  
         eval {  
             ($apache) =  
                 (Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)});  
         };  
         if ($@) {  
            $apache = 1.3;  
         }  
     }  
   
 }  }
 }  }
   
Line 13220  server ($udom and $uhome are optional) Line 13263  server ($udom and $uhome are optional)
   
 =item *   =item * 
   
 get_domain_defaults($target_domain) : returns hash with defaults for  get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults 
 authentication and language in the domain. Keys are: auth_def, auth_arg_def,  for: authentication, language, quotas, timezone, date locale, and portal URL in
 lang_def; corresponsing values are authentication type (internal, krb4, krb5,  the target domain.
 or localauth), initial password or a kerberos realm, language (e.g., en-us).  
 Values are retrieved from cache (if current), or from domain's configuration.db  May also include additional key => value pairs for the following groups:
 (if available), or lastly from values in lonTabs/dns_domain,tab,   
 or lonTabs/domain.tab.   =over
   
   =item
   disk quotas (MB allocated by default to portfolios and authoring spaces).
   
   =over
   
   =item defaultquota, authorquota
   
   =back
   
   =item
   tools (availability of aboutme page, blog, webDAV access for authoring spaces,
   portfolio for users).
   
   =over
   
   =item
   aboutme, blog, webdav, portfolio
   
   =back
   
   =item
   requestcourses: ability to request courses, and how requests are processed.
   
   =over
   
   =item
   official, unofficial, community, textbook
   
   =back
   
   =item
   inststatus: types of institutional affiliation, and order in which they are displayed.
   
   =over
   
   =item
   inststatustypes, inststatusorder
   
   =back
   
   =item
   coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
   for course's uploaded content.
   
   =over
   
   =item
   canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, 
   communityquota, textbookquota
   
   =back
   
   =item
   usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
   on your servers.
   
   =over
   
   =item 
   remotesessions, hostedsessions
   
   =back
   
   =back
   
   In cases where a domain coordinator has never used the "Set Domain Configuration"
   utility to create a configuration.db file on a domain's primary library server 
   only the following domain defaults: auth_def, auth_arg_def, lang_def
   -- corresponding values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us) -- 
   will be available. Values are retrieved from cache (if current), unless the
   optional $ignore_cache arg is true, or from domain's configuration.db (if available),
   or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
   
   Typical usage:
   
 %domdefaults = &get_auth_defaults($target_domain);  %domdefaults = &get_domain_defaults($target_domain);
   
 =back  =back
   
Removed from v.1.1238  
changed lines
  Added in v.1.1250

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