Diff for /loncom/interface/loncommon.pm between versions 1.283 and 1.300

version 1.283, 2005/11/08 03:08:15 version 1.300, 2005/12/01 23:04:08
Line 380  sub coursebrowser_javascript { Line 380  sub coursebrowser_javascript {
    return (<<ENDSTDBRW);     return (<<ENDSTDBRW);
 <script type="text/javascript" language="Javascript" >  <script type="text/javascript" language="Javascript" >
     var stdeditbrowser;      var stdeditbrowser;
     function opencrsbrowser(formname,uname,udom,desc,extra_element) {      function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag) {
         var url = '/adm/pickcourse?';          var url = '/adm/pickcourse?';
         var filter;          var filter;
         if (filter != null) {          if (filter != null) {
Line 403  sub coursebrowser_javascript { Line 403  sub coursebrowser_javascript {
                 url += '&domainfilter='+extra_element;                  url += '&domainfilter='+extra_element;
             }              }
         }          }
           if (multflag !=null && multflag != '') {
               url += '&multiple='+multflag;
           }
         var title = 'Course_Browser';          var title = 'Course_Browser';
         var options = 'scrollbars=1,resizable=1,menubar=0';          var options = 'scrollbars=1,resizable=1,menubar=0';
         options += ',width=700,height=600';          options += ',width=700,height=600';
Line 414  ENDSTDBRW Line 417  ENDSTDBRW
 }  }
   
 sub selectcourse_link {  sub selectcourse_link {
    my ($form,$unameele,$udomele,$desc,$extra_element)=@_;     my ($form,$unameele,$udomele,$desc,$extra_element,$multflag)=@_;
     return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.      return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
         '","'.$udomele.'","'.$desc.'","'.$extra_element.'");'."'>".&mt('Select Course')."</a>";          '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'");'."'>".&mt('Select Course')."</a>";
 }  }
   
 sub check_uncheck_jscript {  sub check_uncheck_jscript {
Line 1149  sub domain_select { Line 1152  sub domain_select {
     } &get_domains;      } &get_domains;
     if ($multiple) {      if ($multiple) {
  $domains{''}=&mt('Any domain');   $domains{''}=&mt('Any domain');
  return &multiple_select_form($name,$value,4,%domains);   return &multiple_select_form($name,$value,4,\%domains);
     } else {      } else {
  return &select_form($name,$value,%domains);   return &select_form($name,$value,%domains);
     }      }
Line 1159  sub domain_select { Line 1162  sub domain_select {
   
 =pod  =pod
   
 =item * multiple_select_form($name,$value,$size,%hash)  =item * multiple_select_form($name,$value,$size,$hash,$order)
   
 Returns a string containing a <select> element int multiple mode  Returns a string containing a <select> element int multiple mode
   
Line 1170  Args: Line 1173  Args:
   $size - number of rows long the select element is    $size - number of rows long the select element is
   $hash - the elements should be 'option' => 'shown text'    $hash - the elements should be 'option' => 'shown text'
           (shown text should already have been &mt())            (shown text should already have been &mt())
     $order - (optional) array ref of the order to show the elments in
   
 =cut  =cut
   
 #-------------------------------------------  #-------------------------------------------
 sub multiple_select_form {  sub multiple_select_form {
     my ($name,$value,$size,$hash)=@_;      my ($name,$value,$size,$hash,$order)=@_;
     my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);      my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
     my $output='';      my $output='';
     if (! defined($size)) {      if (! defined($size)) {
Line 1185  sub multiple_select_form { Line 1189  sub multiple_select_form {
         }          }
     }      }
     $output.="\n<select name='$name' size='$size' multiple='1'>";      $output.="\n<select name='$name' size='$size' multiple='1'>";
     foreach (sort(keys(%$hash))) {      my @order = ref($order) ? @$order
         $output.='<option value="'.$_.'" ';                              : sort(keys(%$hash));
         $output.='selected="selected" ' if ($selected{$_});      foreach my $key (@order) {
         $output.='>'.$hash->{$_}."</option>\n";          $output.='<option value="'.$key.'" ';
           $output.='selected="selected" ' if ($selected{$key});
           $output.='>'.$hash->{$key}."</option>\n";
     }      }
     $output.="</select>\n";      $output.="</select>\n";
     return $output;      return $output;
Line 1914  if $first is set to 'lastname' then it r Line 1920  if $first is set to 'lastname' then it r
   
 =cut  =cut
   
   
 ###############################################################  ###############################################################
 sub plainname {  sub plainname {
     my ($uname,$udom,$first)=@_;      my ($uname,$udom,$first)=@_;
     my %names=&Apache::lonnet::get('environment',      my %names=&getnames($uname,$udom);
                     ['firstname','middlename','lastname','generation'],  
  $udom,$uname);  
     my $name=&Apache::lonnet::format_name($names{'firstname'},      my $name=&Apache::lonnet::format_name($names{'firstname'},
   $names{'middlename'},    $names{'middlename'},
   $names{'lastname'},    $names{'lastname'},
Line 1950  if the user does not Line 1955  if the user does not
   
 sub nickname {  sub nickname {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my %names;      my %names=&getnames($uname,$udom);
     if ($uname eq $env{'user.name'} &&  
  $udom eq $env{'user.domain'}) {  
  %names=('nickname'   => $env{'environment.nickname'}  ,  
  'firstname'  => $env{'environment.firstname'} ,  
  'middlename' => $env{'environment.middlename'},  
  'lastname'   => $env{'environment.lastname'}  ,  
  'generation' => $env{'environment.generation'});  
     } else {  
  %names=&Apache::lonnet::get('environment',  
     ['nickname','firstname','middlename',  
      'lastname','generation'],$udom,$uname);  
     }  
     my $name=$names{'nickname'};      my $name=$names{'nickname'};
     if ($name) {      if ($name) {
        $name='&quot;'.$name.'&quot;';          $name='&quot;'.$name.'&quot;'; 
Line 1975  sub nickname { Line 1968  sub nickname {
     return $name;      return $name;
 }  }
   
   sub getnames {
       my ($uname,$udom)=@_;
       my $id=$uname.':'.$udom;
       my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
       if ($cached) {
    return %{$names};
       } else {
    my %loadnames=&Apache::lonnet::get('environment',
                       ['firstname','middlename','lastname','generation','nickname'],
    $udom,$uname);
    &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
    return %loadnames;
       }
   }
   
 # ------------------------------------------------------------------ Screenname  # ------------------------------------------------------------------ Screenname
   
Line 2771  sub bodytag { Line 2778  sub bodytag {
 <style type="text/css">  <style type="text/css">
 h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }  h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }
 a:focus { color: red; background: yellow }   a:focus { color: red; background: yellow } 
   table.thinborder { border-collapse: collapse; }
   table.thinborder tr th, table.thinborder tr td { border-style: solid; border-width: 1px}
   form, .inline { display: inline; }
   .center { text-align: center; }
 </style>  </style>
 <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"  <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
 style="margin-top: 0px;$addstyle" $addentries>  style="margin-top: 0px;$addstyle" $addentries>
Line 3073  sub get_sections { Line 3084  sub get_sections {
 }  }
   
 ###############################################  ###############################################
                                                                                     
   =pod
                                                                                     
   =item coursegroups
   
   Retrieve information about groups in a course,
   
   Input:
   1. Reference to hash to populate with group information. 
   2. Optional course domain
   3. Optional course number
   4. Optional group name
   
   Course domain and number will be taken from user's
   environment if not supplied. Optional group name will'
   be passed to lonnet::get_coursegroups() as a regexp to
   use in the call to the dump function.
   
   Output
   Returns number of groups in the course (subject to the
   optional group name filter).
   
   Side effects:
   Populates the referenced curr_groups hash, with key,
   value pairs. Keys are group names, corresponding values
   are scalars containing group information in XML. This
   can be sent to &get_group_settings() to be parsed.     
   
   =cut 
   
   ###############################################
   
   sub coursegroups {
       my ($curr_groups,$cdom,$cnum,$group) = @_;
       my $numgroups;
       if (!defined($cdom) || !defined($cnum)) {
           my $cid =  $env{'request.course.id'};
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
       }
       %{$curr_groups} = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group);
       my ($tmp) = keys(%{$curr_groups});
       if ($tmp=~/^error:/) {
           unless ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {
               &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.
                                                                      $cdom);
           }
           $numgroups = 0;
       } else {
           $numgroups = keys(%{$curr_groups});
       }
       return $numgroups;
   }
   
   ###############################################
   
   =pod
   
   =item get_group_settings
   
   Uses TokeParser to extract group information from the
   XML used to describe course groups.
   
   Input:
   Scalar containing XML  - as retrieved from &coursegroups().
   
   Output:
   Hash containing group information as key=values for (a), and
   hash of hashes for (b)
   
   Keys (in two categories):
   (a) groupname, creator, creation, modified, startdate,enddate.
   Corresponding values are name of the group, creator of the group
   (username:domain), UNIX time for date group was created, and
   settings were last modified, and default start and end access
   times for group members.
   
   (b) functions returned in hash of hashes.
   Outer hash key is functions.
   Inner hash keys are chat,discussion,email,files,homepage,roster.
   Corresponding values are either on or off, depending on
   whther this type of functionality is available for the group.
   
   =cut
                                                                                    
   ###############################################
   
   sub get_group_settings {
       my ($groupinfo)=@_;
       my $parser=HTML::TokeParser->new(\$groupinfo);
       my $token;
       my $tool = '';
       my %content=();
       while ($token=$parser->get_token) {
           if ($token->[0] eq 'S')  {
               my $entry=$token->[1];
               if ($entry eq 'functions') {
                   %{$content{$entry}} = ();
                   $tool = $entry;
               } else {
                   my $value=$parser->get_text('/'.$entry);
                   if ($entry eq 'name') {
                       if ($tool eq 'functions') {
                           my $function = $token->[2]{id};
                           $content{$tool}{$function} = $value;
                       }
                   } elsif ($entry eq 'groupname') {
                       $content{$entry}=&Apache::lonnet::unescape($value);
                   } else {
                       $content{$entry}=$value;
                   }
               }
           } elsif ($token->[0] eq 'E') {
               if ($token->[1] eq 'functions') {
                   $tool = '';
               }
           }
       }
       return %content;
   }
   
   sub check_group_access {
       my ($group) = @_;
       my $access = 1;
       my $now = time;
       my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group});
       if (($end!=0) && ($end<$now)) { $access = 0; }
       if (($start!=0) && ($start>$now)) { $access=0; }
       return $access;
   }
   
   ###############################################
   
 =pod  =pod
                                                                                                                                                                   
Line 3087  Incoming parameters: Line 3230  Incoming parameters:
 3. access status: users must have - either active,   3. access status: users must have - either active, 
 previous, future, or all.  previous, future, or all.
 4. reference to array of permissible roles  4. reference to array of permissible roles
 5. reference to results object (hash of hashes).  5. reference to array of section restrictions (optional)
   6. reference to results object (hash of hashes).
   7. reference to optional userdata hash
 Keys of top level hash are roles.  Keys of top level hash are roles.
 Keys of inner hashes are username:domain, with   Keys of inner hashes are username:domain, with 
 values set to access type.  values set to access type.
                                                                                   Optional userdata hash returns an array with arguments in the 
   same order as loncoursedata::get_classlist() for student data.
   
   Entries for end, start, section and status are blank because
   of the possibility of multiple values for non-student roles.
   
 =cut  =cut
                                                                                                                                                                   
 ###############################################  ###############################################
                                                                                                                                                                   
 sub get_course_users {  sub get_course_users {
     my ($cdom,$cnum,$types,$roles,$users) = @_;      my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_;
     if (grep/^st$/,@{$roles}) {      my %idx = ();
         my $statusidx = &Apache::loncoursedata::CL_STATUS();  
         my $startidx = &Apache::loncoursedata::CL_START();      $idx{udom} = &Apache::loncoursedata::CL_SDOM();
         my $endidx = &Apache::loncoursedata::CL_END();      $idx{uname} =  &Apache::loncoursedata::CL_SNAME();
       $idx{end} = &Apache::loncoursedata::CL_END();
       $idx{start} = &Apache::loncoursedata::CL_START();
       $idx{id} = &Apache::loncoursedata::CL_ID();
       $idx{section} = &Apache::loncoursedata::CL_SECTION();
       $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
       $idx{status} = &Apache::loncoursedata::CL_STATUS();
   
       if (grep(/^st$/,@{$roles})) {
         my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);          my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
         my $now = time;          my $now = time;
         foreach my $student (keys(%{$classlist})) {          foreach my $student (keys(%{$classlist})) {
               my $match = 0;
               if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
    unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/,
       @{$sections})) {
       next;
    }
               } 
             if (defined($$types{'active'})) {              if (defined($$types{'active'})) {
                 if ($$classlist{$student}[$statusidx] eq 'Active') {                  if ($$classlist{$student}[$idx{status}] eq 'Active') {
                     push(@{$$users{st}{$student}},'active');                      push(@{$$users{st}{$student}},'active');
                       $match = 1;
                 }                  }
             }              }
             if (defined($$types{'previous'})) {              if (defined($$types{'previous'})) {
                 if ($$classlist{$student}[$endidx] <= $now) {                  if ($$classlist{$student}[$idx{end}] <= $now) {
                     push(@{$$users{st}{$student}},'previous');                      push(@{$$users{st}{$student}},'previous');
                       $match = 1;
                 }                  }
             }              }
             if (defined($$types{'future'})) {              if (defined($$types{'future'})) {
                 if (($$classlist{$student}[$startidx] > $now) && ($$classlist{$student}[$endidx] > $now) || ($$classlist{$student}[$endidx] == 0) || ($$classlist{$student}[$endidx] eq '')) {                  if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) {
                     push(@{$$users{st}{$student}},'future');                      push(@{$$users{st}{$student}},'future');
                       $match = 1;
                 }                  }
             }              }
               if ($match && defined($userdata)) {
                   $$userdata{$student} = $$classlist{$student};
               }
         }          }
     }      }
     if ((@{$roles} > 0) && (@{$roles} ne "st")) {      if ((@{$roles} > 0) && (@{$roles} ne "st")) {
         my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);          my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);
         foreach my $person (@coursepersonnel) {          foreach my $person (@coursepersonnel) {
               my $match = 0;
             my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);              my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);
             $user =~ s/:$//;              $user =~ s/:$//;
             if (($role) && (grep(/^$role$/,@{$roles}))) {              if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) {
                 my ($uname,$udom) = split(/:/,$user);                  my ($uname,$udom,$usec) = split(/:/,$user);
                   if ($usec ne '' && (ref($sections) eq 'ARRAY') && 
       @{$sections} > 0) {
       unless(grep(/^\Q$usec\E$/,@{$sections})) {
    next;
       }
                   }
                 if ($uname ne '' && $udom ne '') {                  if ($uname ne '' && $udom ne '') {
                     my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);                      my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);
                     foreach my $type (keys(%{$types})) {                       foreach my $type (keys(%{$types})) { 
                         if ($status eq $type) {                          if ($status eq $type) {
                             $$users{$role}{$user} = $type;                              @{$$users{$role}{$user}} = $type;
                               $match = 1;
                         }                          }
                     }                      }
                       if ($match && defined($userdata) &&
                           !exists($$userdata{$uname.':'.$udom})) {
    &get_user_info($udom,$uname,\%idx,$userdata);
                       }
                 }                  }
             }              }
         }          }
         if (grep/^ow$/,@{$roles}) {          if (grep(/^ow$/,@{$roles})) {
             if ((defined($cdom)) && (defined($cnum))) {              if ((defined($cdom)) && (defined($cnum))) {
                 my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);                  my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
                 if ( defined($csettings{'internal.courseowner'}) ) {                  if ( defined($csettings{'internal.courseowner'}) ) {
                     my $owner = $csettings{'internal.courseowner'};                      my $owner = $csettings{'internal.courseowner'};
                     $$users{'ow'}{$owner.':'.$cdom} = 'any';                      @{$$users{'ow'}{$owner.':'.$cdom}} = 'any';
                       if (defined($userdata) && 
    !exists($$userdata{$owner.':'.$cdom})) {
    &get_user_info($cdom,$owner,\%idx,$userdata);
       }
                 }                  }
             }              }
         }          }
Line 3152  sub get_course_users { Line 3339  sub get_course_users {
     return;      return;
 }  }
   
   sub get_user_info {
       my ($udom,$uname,$idx,$userdata) = @_;
       $$userdata{$uname.':'.$udom}[$$idx{fullname}] = 
    &plainname($uname,$udom,'lastname');
       $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
       $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
       return;
   }
   
 ###############################################  ###############################################
   
Line 3292  sub no_cache { Line 3486  sub no_cache {
   
 sub content_type {  sub content_type {
     my ($r,$type,$charset) = @_;      my ($r,$type,$charset) = @_;
       if ($r) {
    #  Note that printout.pl calls this with undef for $r.
    &no_cache($r);
       }
     if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }      if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
     unless ($charset) {      unless ($charset) {
  $charset=&Apache::lonlocal::current_encoding;   $charset=&Apache::lonlocal::current_encoding;
Line 4157  sub store_course_settings { Line 4355  sub store_course_settings {
     # save to the environment      # save to the environment
     # appenv the same items, just to be safe      # appenv the same items, just to be safe
     my $courseid = $env{'request.course.id'};      my $courseid = $env{'request.course.id'};
     my $coursedom = $env{'course.'.$courseid.'.domain'};      my $udom  = $env{'user.domain'};
       my $uname = $env{'user.name'};
     my ($prefix,$Settings) = @_;      my ($prefix,$Settings) = @_;
     my %SaveHash;      my %SaveHash;
     my %AppHash;      my %AppHash;
     while (my ($setting,$type) = each(%$Settings)) {      while (my ($setting,$type) = each(%$Settings)) {
         my $basename = 'internal.'.$prefix.'.'.$setting;          my $basename = join('.','internal',$courseid,$prefix,$setting);
         my $envname = 'course.'.$courseid.'.'.$basename;          my $envname = 'environment.'.$basename;
         if (exists($env{'form.'.$setting})) {          if (exists($env{'form.'.$setting})) {
             # Save this value away              # Save this value away
             if ($type eq 'scalar' &&              if ($type eq 'scalar' &&
Line 4191  sub store_course_settings { Line 4390  sub store_course_settings {
         }          }
     }      }
     my $put_result = &Apache::lonnet::put('environment',\%SaveHash,      my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
                                           $coursedom,                                            $udom,$uname);
                                           $env{'course.'.$courseid.'.num'});  
     if ($put_result !~ /^(ok|delayed)/) {      if ($put_result !~ /^(ok|delayed)/) {
         &Apache::lonnet::logthis('unable to save form parameters, '.          &Apache::lonnet::logthis('unable to save form parameters, '.
                                  'got error:'.$put_result);                                   'got error:'.$put_result);
Line 4207  sub restore_course_settings { Line 4405  sub restore_course_settings {
     my ($prefix,$Settings) = @_;      my ($prefix,$Settings) = @_;
     while (my ($setting,$type) = each(%$Settings)) {      while (my ($setting,$type) = each(%$Settings)) {
         next if (exists($env{'form.'.$setting}));          next if (exists($env{'form.'.$setting}));
         my $envname = 'course.'.$courseid.'.internal.'.$prefix.          my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
             '.'.$setting;              '.'.$setting;
         if (exists($env{$envname})) {          if (exists($env{$envname})) {
             if ($type eq 'scalar') {              if ($type eq 'scalar') {

Removed from v.1.283  
changed lines
  Added in v.1.300


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