[BACK]Return to loncommon.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/loncommon.pm between versions 1.653 and 1.661

version 1.653, 2008/05/19 17:00:22 version 1.661, 2008/06/16 23:34:12
Line 67  use Apache::loncoursedata(); Line 67  use Apache::loncoursedata();
 use Apache::lontexconvert();  use Apache::lontexconvert();
 use Apache::lonclonecourse();  use Apache::lonclonecourse();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
   use DateTime::TimeZone;
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
 use vars qw(%defaultdesign);  use vars qw(%defaultdesign);
Line 634  ENDSCRT Line 635  ENDSCRT
     return $jscript;      return $jscript;
 }  }
   
   sub select_timezone {
      my ($name,$selected,$onchange,$includeempty)=@_;
      my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
      if ($includeempty) {
          $output .= '<option value=""';
          if (($selected eq '') || ($selected eq 'local')) {
              $output .= ' selected="selected" ';
          }
          $output .= '> </option>';
      }
      my @timezones = DateTime::TimeZone->all_names;
      foreach my $tzone (@timezones) {
          $output.= '<option value="'.$tzone.'"';
          if ($tzone eq $selected) {
              $output.=' selected="selected"';
          }
          $output.=">$tzone</option>\n";
      }
      $output.="</select>";
      return $output;
   }
   
 =pod  =pod
   
Line 2932  sub display_languages { Line 2954  sub display_languages {
   
 sub preferred_languages {  sub preferred_languages {
     my @languages=();      my @languages=();
       if (($env{'request.role.adv'}) && ($env{'form.languages'})) {
           @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$env{'form.languages'}));
       }
     if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {      if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
  @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,   @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
          $env{'course.'.$env{'request.course.id'}.'.languages'}));           $env{'course.'.$env{'request.course.id'}.'.languages'}));
     }      }
   
     if ($env{'environment.languages'}) {      if ($env{'environment.languages'}) {
  @languages=(@languages,   @languages=(@languages,
     split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));      split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));
Line 7009  sub get_env_multiple { Line 7035  sub get_env_multiple {
     return(@values);      return(@values);
 }  }
   
   sub ask_for_embedded_content {
       my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
       my $upload_output = '
      <form name="upload_embedded" action="'.$actionurl.'"
                     method="post" enctype="multipart/form-data">';
       $upload_output .= $state;
       $upload_output .= '<b>Upload embedded files</b>:<br />'.&start_data_table();
   
       my $num = 0;
       foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%{$allfiles})) {
           $upload_output .= &start_data_table_row().
               '<td>'.$embed_file.'</td><td>';
           if ($args->{'ignore_remote_references'}
               && $embed_file =~ m{^\w+://}) {
               $upload_output.='<span class="LC_warning">'.&mt("URL points to other server.").'</span>';
           } elsif ($args->{'error_on_invalid_names'}
               && $embed_file ne &Apache::lonnet::clean_filename($embed_file,{'keep_path' => 1,})) {
   
               $upload_output.='<span class="LC_warning">'.&mt("Invalid characters").'</span>';
   
           } else {
               $upload_output .='
              <input name="embedded_item_'.$num.'" type="file" value="" />
              <input name="embedded_orig_'.$num.'" type="hidden" value="'.&escape($embed_file).'" />';
               my $attrib = join(':',@{$$allfiles{$embed_file}});
               $upload_output .=
                   "\n\t\t".
                   '<input name="embedded_attrib_'.$num.'" type="hidden" value="'.
                   $attrib.'" />';
               if (exists($$codebase{$embed_file})) {
                   $upload_output .=
                       "\n\t\t".
                       '<input name="codebase_'.$num.'" type="hidden" value="'.
                       &escape($$codebase{$embed_file}).'" />';
               }
           }
           $upload_output .= '</td>'.&Apache::loncommon::end_data_table_row();
           $num++;
       }
       $upload_output .= &Apache::loncommon::end_data_table().'<br />
      <input type ="hidden" name="number_embedded_items" value="'.$num.'" />
      <input type ="submit" value="'.&mt('Upload Listed Files').'" />
      '.&mt('(only files for which a location has been provided will be uploaded)').'
      </form>';
       return $upload_output;
   }
   
   sub upload_embedded {
       my ($context,$dirpath,$uname,$udom,$dir_root,$url_root,$group,$disk_quota,
           $current_disk_usage) = @_;
       my $output;
       for (my $i=0; $i<$env{'form.number_embedded_items'}; $i++) {
           next if (!exists($env{'form.embedded_item_'.$i.'.filename'}));
           my $orig_uploaded_filename =
               $env{'form.embedded_item_'.$i.'.filename'};
   
           $env{'form.embedded_orig_'.$i} =
               &unescape($env{'form.embedded_orig_'.$i});
           my ($path,$fname) =
               ($env{'form.embedded_orig_'.$i} =~ m{(.*/)([^/]*)});
           # no path, whole string is fname
           if (!$fname) { $fname = $env{'form.embedded_orig_'.$i} };
   
           $path = $env{'form.currentpath'}.$path;
           $fname = &Apache::lonnet::clean_filename($fname);
           # See if there is anything left
           next if ($fname eq '');
   
           # Check if file already exists as a file or directory.
           my ($state,$msg);
           if ($context eq 'portfolio') {
               my $port_path = $dirpath;
               if ($group ne '') {
                   $port_path = "groups/$group/$port_path";
               }
               ($state,$msg) = &check_for_upload($path,$fname,$group,'embedded_item_'.$i,
                                                 $dir_root,$port_path,$disk_quota,
                                                 $current_disk_usage,$uname,$udom);
               if ($state eq 'will_exceed_quota'
                   || $state eq 'file_locked'
                   || $state eq 'file_exists' ) {
                   $output .= $msg;
                   next;
               }
           } elsif (($context eq 'author') || ($context eq 'testbank')) {
               ($state,$msg) = &check_for_existing($path,$fname,'embedded_item_'.$i);
               if ($state eq 'exists') {
                   $output .= $msg;
                   next;
               }
           }
           # Check if extension is valid
           if (($fname =~ /\.(\w+)$/) &&
               (&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
               $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1);
               next;
           } elsif (($fname =~ /\.(\w+)$/) &&
                    (!defined(&Apache::loncommon::fileembstyle($1)))) {
               $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1);
               next;
           } elsif ($fname=~/\.(\d+)\.(\w+)$/) {
               $output .= &mt('File name not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2);
               next;
           }
   
           $env{'form.embedded_item_'.$i.'.filename'}=$fname;
           if ($context eq 'portfolio') {
               my $result=
                   &Apache::lonnet::userfileupload('embedded_item_'.$i,'',
                                                   $dirpath.$path);
               if ($result !~ m|^/uploaded/|) {
                   $output .= '<span class="LC_error">'
                         .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].'
                              ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i})
                         .'</span><br />';
                   next;
               } else {
                   $output .= '<p>'.&mt('Uploaded [_1]','<span class="LC_filename">'.
                              $path.$fname.'</span>').'</p>';     
               }
           } else {
   # Save the file
               my $target = $env{'form.embedded_item_'.$i};
               my $fullpath = $dir_root.$dirpath.'/'.$path;
               my $dest = $fullpath.$fname;
               my $url = $url_root.$dirpath.'/'.$path.$fname;
               my @parts=split(/\//,$fullpath);
               my $count;
               my $filepath = $dir_root;
               for ($count=4;$count<=$#parts;$count++) {
                   $filepath .= "/$parts[$count]";
                   if ((-e $filepath)!=1) {
                       mkdir($filepath,0770);
                   }
               }
               my $fh;
               if (!open($fh,'>'.$dest)) {
                   &Apache::lonnet::logthis('Failed to create '.$dest);
                   $output .= '<span class="LC_error">'.
                              &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
                              '</span><br />';
               } else {
                   if (!print $fh $env{'form.embedded_item_'.$i}) {
                       &Apache::lonnet::logthis('Failed to write to '.$dest);
                       $output .= '<span class="LC_error">'.
                                 &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
                                 '</span><br />';
                   } else {
                       if ($context eq 'testbank') {
                           $output .= &mt('Embedded file uploaded successfully:').
                                      '&nbsp;<a href="'.$url.'">'.
                                      $orig_uploaded_filename.'</a><br />';
                       } else {
                           $output .= '<font size="+2">'.
                                      &mt('View embedded file: [_1]','<a href="'.$url.'">'.
                                      $orig_uploaded_filename.'</a>').'</font><br />';
                       }
                   }
                   close($fh);
               }
           }
       }
       return $output;
   }
   
   sub check_for_existing {
       my ($path,$fname,$element) = @_;
       my ($state,$msg);
       if (-d $path.'/'.$fname) {
           $state = 'exists';
           $msg = &mt('Unable to upload [_1]. A directory by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
       } elsif (-e $path.'/'.$fname) {
           $state = 'exists';
           $msg = &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
       }
       if ($state eq 'exists') {
           $msg = '<span class="LC_error">'.$msg.'</span><br />';
       }
       return ($state,$msg);
   }
   
   sub check_for_upload {
       my ($path,$fname,$group,$element,$portfolio_root,$port_path,
           $disk_quota,$current_disk_usage,$uname,$udom) = @_;
       my $filesize = (length($env{'form.'.$element})) / 1000; #express in k (1024?)
       my $getpropath = 1;
       my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname,
                                               $getpropath);
       my $found_file = 0;
       my $locked_file = 0;
       foreach my $line (@dir_list) {
           my ($file_name)=split(/\&/,$line,2);
           if ($file_name eq $fname){
               $file_name = $path.$file_name;
               if ($group ne '') {
                   $file_name = $group.$file_name;
               }
               $found_file = 1;
               if (&Apache::lonnet::is_locked($file_name,$udom,$uname) eq 'true') {
                   $locked_file = 1;
               }
           }
       }
       my $getpropath = 1;
       if (($current_disk_usage + $filesize) > $disk_quota){
           my $msg = '<span class="LC_error">'.
                   &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.','<span class="LC_filename">'.$fname.'</span>',$filesize).'</span>'.
                     '<br />'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',$disk_quota,$current_disk_usage);
           return ('will_exceed_quota',$msg);
       } elsif ($found_file) {
           if ($locked_file) {
               my $msg = '<span class="LC_error">';
               $msg .= &mt('Unable to upload [_1]. A locked file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>','<span class="LC_filename">'.$port_path.$env{'form.currentpath'}.'</span>');
               $msg .= '</span><br />';
               $msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.','<span class="LC_filename">'.$fname.'</span>');
               return ('file_locked',$msg);
           } else {
               my $msg = '<span class="LC_error">';
               $msg .= &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$port_path.$env{'form.currentpath'});
               $msg .= '</span>';
               $msg .= '<br />';
               $msg .= &mt('To upload, rename or delete existing [_1] in [_2].','<span class="LC_filename">'.$fname.'</span>', $port_path.$env{'form.currentpath'});
               return ('file_exists',$msg);
           }
       }
   }
   
   
 =pod  =pod
   
Line 7951  defdom (domain for which to retrieve con Line 8204  defdom (domain for which to retrieve con
 origmail (scalar - email address of recipient from loncapa.conf,   origmail (scalar - email address of recipient from loncapa.conf, 
 i.e., predates configuration by DC via domainprefs.pm   i.e., predates configuration by DC via domainprefs.pm 
   
 Returns: comma separated list of addresses to which to send e-mail.     Returns: comma separated list of addresses to which to send e-mail.
   
   =back
   
 =cut  =cut
   
Line 8002  sub build_recipient_list { Line 8257  sub build_recipient_list {
 ############################################################  ############################################################
 ############################################################  ############################################################
   
   =pod
   
   =head1 Course Catalog Routines
   
   =over 4
   
   =item * &gather_categories()
   
   Converts category definitions - keys of categories hash stored in  
   coursecategories in configuration.db on the primary library server in a 
   domain - to an array.  Also generates javascript and idx hash used to 
   generate Domain Coordinator interface for editing Course Categories.
   
   Inputs:
   categories (reference to hash of category definitions).
   cats (reference to array of arrays/hashes which encapsulates hierarchy of
         categories and subcategories).
   idx (reference to hash of counters used in Domain Coordinator interface for 
         editing Course Categories).
   jsarray (reference to array of categories used to create Javascript arrays for
            Domain Coordinator interface for editing Course Categories).
   
   Returns: nothing
   
   Side effects: populates cats, idx and jsarray. 
   
   =cut
   
   sub gather_categories {
       my ($categories,$cats,$idx,$jsarray) = @_;
       my %counters;
       my $num = 0;
       foreach my $item (keys(%{$categories})) {
           my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item);
           if ($container eq '' && $depth == 0) {
               $cats->[$depth][$categories->{$item}] = $cat;
           } else {
               $cats->[$depth]{$container}[$categories->{$item}] = $cat;
           }
           my ($escitem,$tail) = split(/:/,$item,2);
           if ($counters{$tail} eq '') {
               $counters{$tail} = $num;
               $num ++;
           }
           if (ref($idx) eq 'HASH') {
               $idx->{$item} = $counters{$tail};
           }
           if (ref($jsarray) eq 'ARRAY') {
               push(@{$jsarray->[$counters{$tail}]},$item);
           }
       }
       return;
   }
   
   =pod
   
   =item * &extract_categories()
   
   Used to generate breadcrumb trails for course categories.
   
   Inputs:
   categories (reference to hash of category definitions).
   cats (reference to array of arrays/hashes which encapsulates hierarchy of
         categories and subcategories).
   trails (reference to array of breacrumb trails for each category).
   allitems (reference to hash - key is category key 
            (format: escaped(name):escaped(parent category):depth in hierarchy).
   idx (reference to hash of counters used in Domain Coordinator interface for
         editing Course Categories).
   jsarray (reference to array of categories used to create Javascript arrays for
            Domain Coordinator interface for editing Course Categories).
   
   Returns: nothing
   
   Side effects: populates trails and allitems hash references.
   
   =cut
   
   sub extract_categories {
       my ($categories,$cats,$trails,$allitems,$idx,$jsarray) = @_;
       if (ref($categories) eq 'HASH') {
           &gather_categories($categories,$cats,$idx,$jsarray);
           if (ref($cats->[0]) eq 'ARRAY') {
               for (my $i=0; $i<@{$cats->[0]}; $i++) {
                   my $name = $cats->[0][$i];
                   my $item = &escape($name).'::0';
                   my $trailstr;
                   if ($name eq 'instcode') {
                       $trailstr = &mt('Official courses (with institutional codes)');
                   } else {
                       $trailstr = $name;
                   }
                   if ($allitems->{$item} eq '') {
                       push(@{$trails},$trailstr);
                       $allitems->{$item} = scalar(@{$trails})-1;
                   }
                   my @parents = ($name);
                   if (ref($cats->[1]{$name}) eq 'ARRAY') {
                       for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) {
                           my $category = $cats->[1]{$name}[$j];
                           &recurse_categories($cats,2,$category,$trails,$allitems,\@parents);
                       }
                   }
               }
           }
       }
       return;
   }
   
   =pod
   
   =item *&recurse_categories()
   
   Recursively used to generate breadcrumb trails for course categories.
   
   Inputs:
   cats (reference to array of arrays/hashes which encapsulates hierarchy of
         categories and subcategories).
   depth (current depth in hierarchy of categories and sub-categories - 0 indexed).
   category (current course category, for which breadcrumb trail is being generated).   
   trails (reference to array of breacrumb trails for each category).
   allitems (reference to hash - key is category key
            (format: escaped(name):escaped(parent category):depth in hierarchy).
   parents (array containing containers directories for current category, 
            back to top level). 
   
   Returns: nothing
   
   Side effects: populates trails and allitems hash references
   
   =back
   
   =cut
   
   sub recurse_categories {
       my ($cats,$depth,$category,$trails,$allitems,$parents) = @_;
       my $shallower = $depth - 1;
       if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
           for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
               my $name = $cats->[$depth]{$category}[$k];
               my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
               my $trailstr = join(' -&gt; ',(@{$parents},$category));
               if ($allitems->{$item} eq '') {
                   push(@{$trails},$trailstr);
                   $allitems->{$item} = scalar(@{$trails})-1;
               }
               my $deeper = $depth+1;
               push(@{$parents},$category);
               &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents);
               pop(@{$parents});
           }
       } else {
           my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
           my $trailstr = join(' -&gt; ',(@{$parents},$category));
           if ($allitems->{$item} eq '') {
               push(@{$trails},$trailstr);
               $allitems->{$item} = scalar(@{$trails})-1;
           }
       }
       return;
   }
   
   ############################################################
   ############################################################
   
   
 sub commit_customrole {  sub commit_customrole {
     my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;      my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;
     my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.      my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
Removed from v.1.653  
changed lines
  Added in v.1.661

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