--- loncom/interface/loncommon.pm 2012/01/04 00:08:29 1.1050
+++ loncom/interface/loncommon.pm 2016/02/17 19:15:48 1.1233
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1050 2012/01/04 00:08:29 www Exp $
+# $Id: loncommon.pm,v 1.1233 2016/02/17 19:15:48 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -67,9 +67,20 @@ use Apache::lonhtmlcommon();
use Apache::loncoursedata();
use Apache::lontexconvert();
use Apache::lonclonecourse();
+use Apache::lonuserutils();
+use Apache::lonuserstate();
+use Apache::courseclassifier();
use LONCAPA qw(:DEFAULT :match);
use DateTime::TimeZone;
use DateTime::Locale::Catalog;
+use Encode();
+use Text::Aspell;
+use Authen::Captcha;
+use Captcha::reCAPTCHA;
+use Crypt::DES;
+use DynaLoader; # for Crypt::DES version
+use MIME::Lite;
+use MIME::Types;
# ---------------------------------------------- Designs
use vars qw(%defaultdesign);
@@ -154,6 +165,7 @@ sub ssi_with_retries {
# ----------------------------------------------- Filetypes/Languages/Copyright
my %language;
my %supported_language;
+my %supported_codes;
my %latex_language; # For choosing hyphenation in
my %latex_language_bykey; # for choosing hyphenation from metadata
my %cprtag;
@@ -188,14 +200,15 @@ BEGIN {
while (my $line = <$fh>) {
next if ($line=~/^\#/);
chomp($line);
- my ($key,$two,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line));
+ my ($key,$code,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line));
$language{$key}=$val.' - '.$enc;
if ($sup) {
$supported_language{$key}=$sup;
+ $supported_codes{$key} = $code;
}
if ($latex) {
$latex_language_bykey{$key} = $latex;
- $latex_language{$two} = $latex;
+ $latex_language{$code} = $latex;
}
}
close($fh);
@@ -524,7 +537,8 @@ ENDAUTHORBRW
}
sub coursebrowser_javascript {
- my ($domainfilter,$sec_element,$formname,$role_element,$crstype) = @_;
+ my ($domainfilter,$sec_element,$formname,$role_element,$crstype,
+ $credits_element,$instcode) = @_;
my $wintitle = 'Course_Browser';
if ($crstype eq 'Community') {
$wintitle = 'Community_Browser';
@@ -574,7 +588,10 @@ sub coursebrowser_javascript {
if (formname == 'ccrs') {
var ownername = document.forms[formid].ccuname.value;
var ownerdom = document.forms[formid].ccdomain.options[document.forms[formid].ccdomain.selectedIndex].value;
- url += '&cloner='+ownername+':'+ownerdom;
+ url += '&cloner='+ownername+':'+ownerdom+'&crscode='+document.forms[formid].crscode.value;
+ }
+ if (formname == 'requestcrs') {
+ url += '&crsdom=$domainfilter&crscode=$instcode';
}
if (multflag !=null && multflag != '') {
url += '&multiple='+multflag;
@@ -587,8 +604,9 @@ sub coursebrowser_javascript {
}
$id_functions
ENDSTDBRW
- if (($sec_element ne '') || ($role_element ne '')) {
- $output .= &setsec_javascript($sec_element,$formname,$role_element);
+ if (($sec_element ne '') || ($role_element ne '') || ($credits_element ne '')) {
+ $output .= &setsec_javascript($sec_element,$formname,$role_element,
+ $credits_element);
}
$output .= '
// ]]>
@@ -657,7 +675,7 @@ if (!Array.prototype.indexOf) {
var n = 0;
if (arguments.length > 0) {
n = Number(arguments[1]);
- if (n !== n) { // shortcut for verifying if it's NaN
+ if (n !== n) { // shortcut for verifying if it is NaN
n = 0;
} else if (n !== 0 && n !== (1 / 0) && n !== -(1 / 0)) {
n = (n > 0 || -1) * Math.floor(Math.abs(n));
@@ -745,7 +763,7 @@ ENDUSERBRW
}
sub setsec_javascript {
- my ($sec_element,$formname,$role_element) = @_;
+ my ($sec_element,$formname,$role_element,$credits_element) = @_;
my (@courserolenames,@communityrolenames,$rolestr,$courserolestr,
$communityrolestr);
if ($role_element ne '') {
@@ -840,6 +858,14 @@ function setRole(crstype) {
}
|;
}
+ if ($credits_element) {
+ $setsections .= qq|
+function setCredits(defaultcredits) {
+ document.$formname.$credits_element.value = defaultcredits;
+ return;
+}
+|;
+ }
return $setsections;
}
@@ -885,10 +911,14 @@ sub check_uncheck_jscript {
function checkAll(field) {
if (field.length > 0) {
for (i = 0; i < field.length; i++) {
- field[i].checked = true ;
+ if (!field[i].disabled) {
+ field[i].checked = true;
+ }
}
} else {
- field.checked = true
+ if (!field.disabled) {
+ field.checked = true;
+ }
}
}
@@ -959,6 +989,7 @@ sub select_datelocale {
$locale_names{$id} = '('.$en_terr.')';
}
}
+ $locale_names{$id} = Encode::encode('UTF-8',$locale_names{$id});
push (@possibles,$id);
}
}
@@ -970,7 +1001,7 @@ sub select_datelocale {
}
$output.=">$item";
if ($locale_names{$item} ne '') {
- $output.=" $locale_names{$item}\n";
+ $output.=' '.$locale_names{$item};
}
$output.="\n";
}
@@ -990,11 +1021,39 @@ sub select_language {
$langchoices{$code} = &plainlanguagedescription($id);
}
}
+ %langchoices = &Apache::lonlocal::texthash(%langchoices);
return &select_form($selected,$name,\%langchoices);
}
=pod
+
+=item * &list_languages()
+
+Returns an array reference that is suitable for use in language prompters.
+Each array element is itself a two element array. The first element
+is the language code. The second element a descsriptiuon of the
+language itself. This is suitable for use in e.g.
+&Apache::edit::select_arg (once dereferenced that is).
+
+=cut
+
+sub list_languages {
+ my @lang_choices;
+
+ foreach my $id (&languageids()) {
+ my $code = &supportedlanguagecode($id);
+ if ($code) {
+ my $selector = $supported_codes{$id};
+ my $description = &plainlanguagedescription($id);
+ push (@lang_choices, [$selector, $description]);
+ }
+ }
+ return \@lang_choices;
+}
+
+=pod
+
=item * &linked_select_forms(...)
linked_select_forms returns a string containing a block
@@ -1021,6 +1080,12 @@ linked_select_forms takes the following
=item * $menuorder, the order of values in the first menu
+=item * $onchangefirst, additional javascript call to execute for an onchange
+ event for the first
'.
&Apache::loncommon::end_page();
if (ref($r)) {
$r->print($page);
@@ -7586,9 +8903,8 @@ role status: active, previous or future.
sub check_user_status {
my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
- my $extra = &Apache::lonnet::freeze_escape({'skipcheck' => 1});
- my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname,'.',undef,$extra);
- my @uroles = keys %userinfo;
+ my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
+ my @uroles = keys(%userinfo);
my $srchstr;
my $active_chk = 'none';
my $now = time;
@@ -7665,7 +8981,19 @@ sub get_sections {
my %sectioncount;
my $now = time;
- if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
+ my $check_students = 1;
+ my $only_students = 0;
+ if (ref($possible_roles) eq 'ARRAY') {
+ if (grep(/^st$/,@{$possible_roles})) {
+ if (@{$possible_roles} == 1) {
+ $only_students = 1;
+ }
+ } else {
+ $check_students = 0;
+ }
+ }
+
+ if ($check_students) {
my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
my $sec_index = &Apache::loncoursedata::CL_SECTION();
my $status_index = &Apache::loncoursedata::CL_STATUS();
@@ -7692,6 +9020,9 @@ sub get_sections {
}
}
}
+ if ($only_students) {
+ return %sectioncount;
+ }
my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
foreach my $user (sort(keys(%courseroles))) {
if ($user !~ /^(\w{2})/) { next; }
@@ -7839,7 +9170,7 @@ sub get_course_users {
active => 'Active',
future => 'Future',
);
- my %nothide;
+ my (%nothide,@possdoms);
if ($hidepriv) {
my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
@@ -7849,6 +9180,10 @@ sub get_course_users {
$nothide{$user} = 1;
}
}
+ my @possdoms = ($cdom);
+ if ($coursehash{'checkforpriv'}) {
+ push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
+ }
}
foreach my $person (sort(keys(%coursepersonnel))) {
my $match = 0;
@@ -7884,7 +9219,7 @@ sub get_course_users {
}
if ($uname ne '' && $udom ne '') {
if ($hidepriv) {
- if ((&Apache::lonnet::privileged($uname,$udom)) &&
+ if ((&Apache::lonnet::privileged($uname,$udom,\@possdoms)) &&
(!$nothide{$uname.':'.$udom})) {
next;
}
@@ -7972,14 +9307,19 @@ sub get_user_info {
=item * &get_user_quota()
-Retrieves quota assigned for storage of portfolio files for a user
+Retrieves quota assigned for storage of user files.
+Default is to report quota for portfolio files.
Incoming parameters:
1. user's username
2. user's domain
+3. quota name - portfolio, author, or course
+ (if no quota name provided, defaults to portfolio).
+4. crstype - official, unofficial, textbook or community, if quota name is
+ course
Returns:
-1. Disk quota (in Mb) assigned to student.
+1. Disk quota (in MB) assigned to student.
2. (Optional) Type of setting: custom or default
(individually assigned or default for user's
institutional status).
@@ -7990,7 +9330,7 @@ Returns:
If a value has been stored in the user's environment,
it will return that, otherwise it returns the maximal default
-defined for the user's instituional status(es) in the domain.
+defined for the user's institutional status(es) in the domain.
=cut
@@ -7998,7 +9338,7 @@ defined for the user's instituional stat
sub get_user_quota {
- my ($uname,$udom) = @_;
+ my ($uname,$udom,$quotaname,$crstype) = @_;
my ($quota,$quotatype,$settingstatus,$defquota);
if (!defined($udom)) {
$udom = $env{'user.domain'};
@@ -8013,27 +9353,58 @@ sub get_user_quota {
$defquota = 0;
} else {
my $inststatus;
- if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
- $quota = $env{'environment.portfolioquota'};
- $inststatus = $env{'environment.inststatus'};
- } else {
- my %userenv =
- &Apache::lonnet::get('environment',['portfolioquota',
- 'inststatus'],$udom,$uname);
- my ($tmp) = keys(%userenv);
- if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
- $quota = $userenv{'portfolioquota'};
- $inststatus = $userenv{'inststatus'};
- } else {
- undef(%userenv);
- }
- }
- ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
- if ($quota eq '') {
- $quota = $defquota;
- $quotatype = 'default';
+ if ($quotaname eq 'course') {
+ if (($env{'course.'.$udom.'_'.$uname.'.num'} eq $uname) &&
+ ($env{'course.'.$udom.'_'.$uname.'.domain'} eq $udom)) {
+ $quota = $env{'course.'.$udom.'_'.$uname.'.internal.uploadquota'};
+ } else {
+ my %cenv = &Apache::lonnet::coursedescription("$udom/$uname");
+ $quota = $cenv{'internal.uploadquota'};
+ }
} else {
- $quotatype = 'custom';
+ if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
+ if ($quotaname eq 'author') {
+ $quota = $env{'environment.authorquota'};
+ } else {
+ $quota = $env{'environment.portfolioquota'};
+ }
+ $inststatus = $env{'environment.inststatus'};
+ } else {
+ my %userenv =
+ &Apache::lonnet::get('environment',['portfolioquota',
+ 'authorquota','inststatus'],$udom,$uname);
+ my ($tmp) = keys(%userenv);
+ if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
+ if ($quotaname eq 'author') {
+ $quota = $userenv{'authorquota'};
+ } else {
+ $quota = $userenv{'portfolioquota'};
+ }
+ $inststatus = $userenv{'inststatus'};
+ } else {
+ undef(%userenv);
+ }
+ }
+ }
+ if ($quota eq '' || wantarray) {
+ if ($quotaname eq 'course') {
+ my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
+ if (($crstype eq 'official') || ($crstype eq 'unofficial') ||
+ ($crstype eq 'community') || ($crstype eq 'textbook')) {
+ $defquota = $domdefs{$crstype.'quota'};
+ }
+ if ($defquota eq '') {
+ $defquota = 500;
+ }
+ } else {
+ ($defquota,$settingstatus) = &default_quota($udom,$inststatus,$quotaname);
+ }
+ if ($quota eq '') {
+ $quota = $defquota;
+ $quotatype = 'default';
+ } else {
+ $quotatype = 'custom';
+ }
}
}
if (wantarray) {
@@ -8053,54 +9424,60 @@ Retrieves default quota assigned for sto
given an (optional) user's institutional status.
Incoming parameters:
+
1. domain
2. (Optional) institutional status(es). This is a : separated list of
status types (e.g., faculty, staff, student etc.)
which apply to the user for whom the default is being retrieved.
If the institutional status string in undefined, the domain
- default quota will be returned.
+ default quota will be returned.
+3. quota name - portfolio, author, or course
+ (if no quota name provided, defaults to portfolio).
Returns:
-1. Default disk quota (in Mb) for user portfolios in the domain.
+
+1. Default disk quota (in MB) for user portfolios in the domain.
2. (Optional) institutional type which determined the value of the
default quota.
If a value has been stored in the domain's configuration db,
it will return that, otherwise it returns 20 (for backwards
compatibility with domains which have not set up a configuration
-db file; the original statically defined portfolio quota was 20 Mb).
+db file; the original statically defined portfolio quota was 20 MB).
If the user's status includes multiple types (e.g., staff and student),
the largest default quota which applies to the user determines the
default quota returned.
-=back
-
=cut
###############################################
sub default_quota {
- my ($udom,$inststatus) = @_;
+ my ($udom,$inststatus,$quotaname) = @_;
my ($defquota,$settingstatus);
my %quotahash = &Apache::lonnet::get_dom('configuration',
['quotas'],$udom);
+ my $key = 'defaultquota';
+ if ($quotaname eq 'author') {
+ $key = 'authorquota';
+ }
if (ref($quotahash{'quotas'}) eq 'HASH') {
if ($inststatus ne '') {
my @statuses = map { &unescape($_); } split(/:/,$inststatus);
foreach my $item (@statuses) {
- if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') {
- if ($quotahash{'quotas'}{'defaultquota'}{$item} ne '') {
+ if (ref($quotahash{'quotas'}{$key}) eq 'HASH') {
+ if ($quotahash{'quotas'}{$key}{$item} ne '') {
if ($defquota eq '') {
- $defquota = $quotahash{'quotas'}{'defaultquota'}{$item};
+ $defquota = $quotahash{'quotas'}{$key}{$item};
$settingstatus = $item;
- } elsif ($quotahash{'quotas'}{'defaultquota'}{$item} > $defquota) {
- $defquota = $quotahash{'quotas'}{'defaultquota'}{$item};
+ } elsif ($quotahash{'quotas'}{$key}{$item} > $defquota) {
+ $defquota = $quotahash{'quotas'}{$key}{$item};
$settingstatus = $item;
}
}
- } else {
+ } elsif ($key eq 'defaultquota') {
if ($quotahash{'quotas'}{$item} ne '') {
if ($defquota eq '') {
$defquota = $quotahash{'quotas'}{$item};
@@ -8114,16 +9491,25 @@ sub default_quota {
}
}
if ($defquota eq '') {
- if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') {
- $defquota = $quotahash{'quotas'}{'defaultquota'}{'default'};
- } else {
+ if (ref($quotahash{'quotas'}{$key}) eq 'HASH') {
+ $defquota = $quotahash{'quotas'}{$key}{'default'};
+ } elsif ($key eq 'defaultquota') {
$defquota = $quotahash{'quotas'}{'default'};
}
$settingstatus = 'default';
+ if ($defquota eq '') {
+ if ($quotaname eq 'author') {
+ $defquota = 500;
+ }
+ }
}
} else {
$settingstatus = 'default';
- $defquota = 20;
+ if ($quotaname eq 'author') {
+ $defquota = 500;
+ } else {
+ $defquota = 20;
+ }
}
if (wantarray) {
return ($defquota,$settingstatus);
@@ -8132,6 +9518,64 @@ sub default_quota {
}
}
+###############################################
+
+=pod
+
+=item * &excess_filesize_warning()
+
+Returns warning message if upload of file to authoring space, or copying
+of existing file within authoring space will cause quota for the authoring
+space to be exceeded.
+
+Same, if upload of a file directly to a course/community via Course Editor
+will cause quota for uploaded content for the course to be exceeded.
+
+Inputs: 7
+1. username or coursenum
+2. domain
+3. context ('author' or 'course')
+4. filename of file for which action is being requested
+5. filesize (kB) of file
+6. action being taken: copy or upload.
+7. quotatype (in course context -- official, unofficial, community or textbook).
+
+Returns: 1 scalar: HTML to display containing warning if quota would be exceeded,
+ otherwise return null.
+
+=back
+
+=cut
+
+sub excess_filesize_warning {
+ my ($uname,$udom,$context,$filename,$filesize,$action,$quotatype) = @_;
+ my $current_disk_usage = 0;
+ my $disk_quota = &get_user_quota($uname,$udom,$context,$quotatype); #expressed in MB
+ if ($context eq 'author') {
+ my $authorspace = $Apache::lonnet::perlvar{'lonDocRoot'}."/priv/$udom/$uname";
+ $current_disk_usage = &Apache::lonnet::diskusage($udom,$uname,$authorspace);
+ } else {
+ foreach my $subdir ('docs','supplemental') {
+ $current_disk_usage += &Apache::lonnet::diskusage($udom,$uname,"userfiles/$subdir",1);
+ }
+ }
+ $disk_quota = int($disk_quota * 1000);
+ if (($current_disk_usage + $filesize) > $disk_quota) {
+ return '
'.
+ &mt("Unable to $action [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.",
+ ''.$filename.'',$filesize).'
'.
+ '
'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',
+ $disk_quota,$current_disk_usage).
+ '
';
+ }
+ return;
+}
+
+###############################################
+
+
+
+
sub get_secgrprole_info {
my ($cdom,$cnum,$needroles,$type) = @_;
my %sections_count = &get_sections($cdom,$cnum);
@@ -8192,7 +9636,7 @@ sub user_picker {
}
$srchterm = $srch->{'srchterm'};
}
- my %lt=&Apache::lonlocal::texthash(
+ my %html_lt=&Apache::lonlocal::texthash(
'usr' => 'Search criteria',
'doma' => 'Domain/institution to search',
'uname' => 'username',
@@ -8205,6 +9649,8 @@ sub user_picker {
'exact' => 'is',
'contains' => 'contains',
'begins' => 'begins with',
+ );
+ my %js_lt=&Apache::lonlocal::texthash(
'youm' => "You must include some text to search for.",
'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
@@ -8214,6 +9660,8 @@ sub user_picker {
'whse' => "When searching by last,first you must include at least one character in the first name.",
'thfo' => "The following need to be corrected before the search can be run:",
);
+ &html_escape(\%html_lt);
+ &js_escape(\%js_lt);
my $domform = &select_dom_form($currdom,'srchdomain',1,1);
my $srchinsel = ' ';
@@ -8228,10 +9676,10 @@ sub user_picker {
next if ($option eq 'crs' && !$env{'request.course.id'});
if ($curr_selected{'srchin'} eq $option) {
$srchinsel .= '
- ';
+ ';
} else {
$srchinsel .= '
- ';
+ ';
}
}
$srchinsel .= "\n \n";
@@ -8240,10 +9688,10 @@ sub user_picker {
foreach my $option ('lastname','lastfirst','uname') {
if ($curr_selected{'srchby'} eq $option) {
$srchbysel .= '
- ';
+ ';
} else {
$srchbysel .= '
- ';
+ ';
}
}
$srchbysel .= "\n \n";
@@ -8252,10 +9700,10 @@ sub user_picker {
foreach my $option ('begins','contains','exact') {
if ($curr_selected{'srchtype'} eq $option) {
$srchtypesel .= '
- ';
+ ';
} else {
$srchtypesel .= '
- ';
+ ';
}
}
$srchtypesel .= "\n \n";
@@ -8340,46 +9788,46 @@ function validateEntry(callingForm) {
if (srchterm == "") {
checkok = 0;
- msg += "$lt{'youm'}\\n";
+ msg += "$js_lt{'youm'}\\n";
}
if (srchtype== 'begins') {
if (srchterm.length < 2) {
checkok = 0;
- msg += "$lt{'thte'}\\n";
+ msg += "$js_lt{'thte'}\\n";
}
}
if (srchtype== 'contains') {
if (srchterm.length < 3) {
checkok = 0;
- msg += "$lt{'thet'}\\n";
+ msg += "$js_lt{'thet'}\\n";
}
}
if (srchin == 'instd') {
if (srchdomain == '') {
checkok = 0;
- msg += "$lt{'yomc'}\\n";
+ msg += "$js_lt{'yomc'}\\n";
}
}
if (srchin == 'dom') {
if (srchdomain == '') {
checkok = 0;
- msg += "$lt{'ymcd'}\\n";
+ msg += "$js_lt{'ymcd'}\\n";
}
}
if (srchby == 'lastfirst') {
if (srchterm.indexOf(",") == -1) {
checkok = 0;
- msg += "$lt{'whus'}\\n";
+ msg += "$js_lt{'whus'}\\n";
}
if (srchterm.indexOf(",") == srchterm.length -1) {
checkok = 0;
- msg += "$lt{'whse'}\\n";
+ msg += "$js_lt{'whse'}\\n";
}
}
if (checkok == 0) {
- alert("$lt{'thfo'}\\n"+msg);
+ alert("$js_lt{'thfo'}\\n"+msg);
return;
}
if (checkok == 1) {
@@ -8397,10 +9845,10 @@ $new_user_create
END_BLOCK
$output .= &Apache::lonhtmlcommon::start_pick_box().
- &Apache::lonhtmlcommon::row_title($lt{'doma'}).
+ &Apache::lonhtmlcommon::row_title($html_lt{'doma'}).
$domform.
&Apache::lonhtmlcommon::row_closure().
- &Apache::lonhtmlcommon::row_title($lt{'usr'}).
+ &Apache::lonhtmlcommon::row_title($html_lt{'usr'}).
$srchbysel.
$srchtypesel.
''.
@@ -8413,56 +9861,160 @@ END_BLOCK
sub user_rule_check {
my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
- my $response;
+ my ($response,%inst_response);
if (ref($usershash) eq 'HASH') {
- foreach my $user (keys(%{$usershash})) {
- my ($uname,$udom) = split(/:/,$user);
- next if ($udom eq '' || $uname eq '');
- my ($id,$newuser);
- if (ref($usershash->{$user}) eq 'HASH') {
- $newuser = $usershash->{$user}->{'newuser'};
- $id = $usershash->{$user}->{'id'};
- }
- my $inst_response;
+ if (keys(%{$usershash}) > 1) {
+ my (%by_username,%by_id,%userdoms);
+ my $checkid;
if (ref($checks) eq 'HASH') {
- if (defined($checks->{'username'})) {
- ($inst_response,%{$inst_results->{$user}}) =
- &Apache::lonnet::get_instuser($udom,$uname);
- } elsif (defined($checks->{'id'})) {
- ($inst_response,%{$inst_results->{$user}}) =
- &Apache::lonnet::get_instuser($udom,undef,$id);
+ if ((!defined($checks->{'username'})) && (defined($checks->{'id'}))) {
+ $checkid = 1;
+ }
+ }
+ foreach my $user (keys(%{$usershash})) {
+ my ($uname,$udom) = split(/:/,$user);
+ if ($checkid) {
+ if (ref($usershash->{$user}) eq 'HASH') {
+ if ($usershash->{$user}->{'id'} ne '') {
+ $by_id{$udom}{$usershash->{$user}->{'id'}} = $uname;
+ $userdoms{$udom} = 1;
+ if (ref($inst_results) eq 'HASH') {
+ $inst_results->{$uname.':'.$udom} = {};
+ }
+ }
+ }
+ } else {
+ $by_username{$udom}{$uname} = 1;
+ $userdoms{$udom} = 1;
+ if (ref($inst_results) eq 'HASH') {
+ $inst_results->{$uname.':'.$udom} = {};
+ }
+ }
+ }
+ foreach my $udom (keys(%userdoms)) {
+ if (!$got_rules->{$udom}) {
+ my %domconfig = &Apache::lonnet::get_dom('configuration',
+ ['usercreation'],$udom);
+ if (ref($domconfig{'usercreation'}) eq 'HASH') {
+ foreach my $item ('username','id') {
+ if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
+ $$curr_rules{$udom}{$item} =
+ $domconfig{'usercreation'}{$item.'_rule'};
+ }
+ }
+ }
+ $got_rules->{$udom} = 1;
+ }
+ }
+ if ($checkid) {
+ foreach my $udom (keys(%by_id)) {
+ my ($outcome,$results) = &Apache::lonnet::get_multiple_instusers($udom,$by_id{$udom},'id');
+ if ($outcome eq 'ok') {
+ foreach my $id (keys(%{$by_id{$udom}})) {
+ my $uname = $by_id{$udom}{$id};
+ $inst_response{$uname.':'.$udom} = $outcome;
+ }
+ if (ref($results) eq 'HASH') {
+ foreach my $uname (keys(%{$results})) {
+ if (exists($inst_response{$uname.':'.$udom})) {
+ $inst_response{$uname.':'.$udom} = $outcome;
+ $inst_results->{$uname.':'.$udom} = $results->{$uname};
+ }
+ }
+ }
+ }
}
} else {
- ($inst_response,%{$inst_results->{$user}}) =
- &Apache::lonnet::get_instuser($udom,$uname);
- return;
+ foreach my $udom (keys(%by_username)) {
+ my ($outcome,$results) = &Apache::lonnet::get_multiple_instusers($udom,$by_username{$udom});
+ if ($outcome eq 'ok') {
+ foreach my $uname (keys(%{$by_username{$udom}})) {
+ $inst_response{$uname.':'.$udom} = $outcome;
+ }
+ if (ref($results) eq 'HASH') {
+ foreach my $uname (keys(%{$results})) {
+ $inst_results->{$uname.':'.$udom} = $results->{$uname};
+ }
+ }
+ }
+ }
}
- if (!$got_rules->{$udom}) {
- my %domconfig = &Apache::lonnet::get_dom('configuration',
- ['usercreation'],$udom);
- if (ref($domconfig{'usercreation'}) eq 'HASH') {
- foreach my $item ('username','id') {
- if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
- $$curr_rules{$udom}{$item} =
- $domconfig{'usercreation'}{$item.'_rule'};
+ } elsif (keys(%{$usershash}) == 1) {
+ my $user = (keys(%{$usershash}))[0];
+ my ($uname,$udom) = split(/:/,$user);
+ if (($udom ne '') && ($uname ne '')) {
+ if (ref($usershash->{$user}) eq 'HASH') {
+ if (ref($checks) eq 'HASH') {
+ if (defined($checks->{'username'})) {
+ ($inst_response{$user},%{$inst_results->{$user}}) =
+ &Apache::lonnet::get_instuser($udom,$uname);
+ } elsif (defined($checks->{'id'})) {
+ if ($usershash->{$user}->{'id'} ne '') {
+ ($inst_response{$user},%{$inst_results->{$user}}) =
+ &Apache::lonnet::get_instuser($udom,undef,
+ $usershash->{$user}->{'id'});
+ } else {
+ ($inst_response{$user},%{$inst_results->{$user}}) =
+ &Apache::lonnet::get_instuser($udom,$uname);
+ }
+ }
+ } else {
+ ($inst_response{$user},%{$inst_results->{$user}}) =
+ &Apache::lonnet::get_instuser($udom,$uname);
+ return;
+ }
+ if (!$got_rules->{$udom}) {
+ my %domconfig = &Apache::lonnet::get_dom('configuration',
+ ['usercreation'],$udom);
+ if (ref($domconfig{'usercreation'}) eq 'HASH') {
+ foreach my $item ('username','id') {
+ if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
+ $$curr_rules{$udom}{$item} =
+ $domconfig{'usercreation'}{$item.'_rule'};
+ }
+ }
}
+ $got_rules->{$udom} = 1;
}
}
- $got_rules->{$udom} = 1;
+ } else {
+ return;
+ }
+ } else {
+ return;
+ }
+ foreach my $user (keys(%{$usershash})) {
+ my ($uname,$udom) = split(/:/,$user);
+ next if (($udom eq '') || ($uname eq ''));
+ my $id;
+ if (ref($inst_results) eq 'HASH') {
+ if (ref($inst_results->{$user}) eq 'HASH') {
+ $id = $inst_results->{$user}->{'id'};
+ }
+ }
+ if ($id eq '') {
+ if (ref($usershash->{$user})) {
+ $id = $usershash->{$user}->{'id'};
+ }
}
foreach my $item (keys(%{$checks})) {
if (ref($$curr_rules{$udom}) eq 'HASH') {
if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
if (@{$$curr_rules{$udom}{$item}} > 0) {
- my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
+ my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,
+ $$curr_rules{$udom}{$item});
foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
if ($rule_check{$rule}) {
$$rulematch{$user}{$item} = $rule;
- if ($inst_response eq 'ok') {
+ if ($inst_response{$user} eq 'ok') {
if (ref($inst_results) eq 'HASH') {
if (ref($inst_results->{$user}) eq 'HASH') {
if (keys(%{$inst_results->{$user}}) == 0) {
$$alerts{$item}{$udom}{$uname} = 1;
+ } elsif ($item eq 'id') {
+ if ($inst_results->{$user}->{'id'} eq '') {
+ $$alerts{$item}{$udom}{$uname} = 1;
+ }
}
}
}
@@ -8489,7 +10041,10 @@ sub user_rule_formats {
my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
if (@{$ruleorder} > 0) {
- $output = ' '.&mt("$text{$check} with the following format(s) may only be used for verified users at [_1]:",$domdesc).'
';
+ $output = ' '.
+ &mt($text{$check}.' with the following format(s) may [_1]only[_2] be used for verified users at [_3]:',
+ '','',$domdesc).
+ '
';
foreach my $rule (@{$ruleorder}) {
if (ref($curr_rules) eq 'ARRAY') {
if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
@@ -8570,7 +10125,14 @@ sub personal_data_fieldtitles {
sub sorted_inst_types {
my ($dom) = @_;
- my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
+ my ($usertypes,$order);
+ my %domdefaults = &Apache::lonnet::get_domain_defaults($dom);
+ if (ref($domdefaults{'inststatus'}) eq 'HASH') {
+ $usertypes = $domdefaults{'inststatus'}{'inststatustypes'};
+ $order = $domdefaults{'inststatus'}{'inststatusorder'};
+ } else {
+ ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
+ }
my $othertitle = &mt('All users');
if ($env{'request.course.id'}) {
$othertitle = &mt('Any users');
@@ -8738,13 +10300,35 @@ future_reservable - ref to hash of stude
sub get_future_slots {
my ($cnum,$cdom,$now,$symb) = @_;
+ my $map;
+ if ($symb) {
+ ($map) = &Apache::lonnet::decode_symb($symb);
+ }
my (%reservable_now,%future_reservable,@sorted_reservable,@sorted_future);
my %slots = &Apache::lonnet::get_course_slots($cnum,$cdom);
foreach my $slot (keys(%slots)) {
next unless($slots{$slot}->{'type'} eq 'schedulable_student');
if ($symb) {
- next if (($slots{$slot}->{'symb'} ne '') &&
- ($slots{$slot}->{'symb'} ne $symb));
+ if ($slots{$slot}->{'symb'} ne '') {
+ my $canuse;
+ my %oksymbs;
+ my @slotsymbs = split(/\s*,\s*/,$slots{$slot}->{'symb'});
+ map { $oksymbs{$_} = 1; } @slotsymbs;
+ if ($oksymbs{$symb}) {
+ $canuse = 1;
+ } else {
+ foreach my $item (@slotsymbs) {
+ if ($item =~ /\.(page|sequence)$/) {
+ (undef,undef,my $sloturl) = &Apache::lonnet::decode_symb($item);
+ if (($map ne '') && ($map eq $sloturl)) {
+ $canuse = 1;
+ last;
+ }
+ }
+ }
+ }
+ next unless ($canuse);
+ }
}
if (($slots{$slot}->{'starttime'} > $now) &&
($slots{$slot}->{'endtime'} > $now)) {
@@ -8818,6 +10402,8 @@ sub get_future_slots {
=pod
+=back
+
=head1 HTTP Helpers
=over 4
@@ -8956,21 +10542,36 @@ sub get_env_multiple {
sub ask_for_embedded_content {
my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
- my (%subdependencies,%dependencies,%mapping,%existing,%newfiles,%pathchanges);
- my $num = 0;
+ my (%subdependencies,%dependencies,%mapping,%existing,%newfiles,%pathchanges,
+ %currsubfile,%unused,$rem);
+ my $counter = 0;
+ my $numnew = 0;
my $numremref = 0;
my $numinvalid = 0;
my $numpathchg = 0;
my $numexisting = 0;
- my ($output,$upload_output,$toplevel,$url,$udom,$uname,$getpropath);
- if (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) {
+ my $numunused = 0;
+ my ($output,$upload_output,$toplevel,$url,$udom,$uname,$getpropath,$cdom,$cnum,
+ $fileloc,$filename,$delete_output,$modify_output,$title,$symb,$path,$navmap);
+ my $heading = &mt('Upload embedded files');
+ my $buttontext = &mt('Upload');
+
+ if ($env{'request.course.id'}) {
+ if ($actionurl eq '/adm/dependencies') {
+ $navmap = Apache::lonnavmaps::navmap->new();
+ }
+ $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ }
+ if (($actionurl eq '/adm/portfolio') ||
+ ($actionurl eq '/adm/coursegrp_portfolio')) {
my $current_path='/';
if ($env{'form.currentpath'}) {
$current_path = $env{'form.currentpath'};
}
if ($actionurl eq '/adm/coursegrp_portfolio') {
- $udom = $env{'course.'.$env{'request.course.id'}.'.domain'};
- $uname = $env{'course.'.$env{'request.course.id'}.'.num'};
+ $udom = $cdom;
+ $uname = $cnum;
$url = '/userfiles/groups/'.$env{'form.group'}.'/portfolio';
} else {
$udom = $env{'user.domain'};
@@ -8990,23 +10591,74 @@ sub ask_for_embedded_content {
}
} elsif ($actionurl eq '/adm/coursedocs') {
if (ref($args) eq 'HASH') {
- $url = $args->{'docs_url'};
- $toplevel = $url;
+ $url = $args->{'docs_url'};
+ $toplevel = $url;
+ if ($args->{'context'} eq 'paste') {
+ ($cdom,$cnum) = ($url =~ m{^\Q/uploaded/\E($match_domain)/($match_courseid)/});
+ ($path) =
+ ($toplevel =~ m{^(\Q/uploaded/$cdom/$cnum/\E(?:docs|supplemental)/(?:default|\d+)/\d+)/});
+ $fileloc = &Apache::lonnet::filelocation('',$toplevel);
+ $fileloc =~ s{^/}{};
+ }
+ }
+ } elsif ($actionurl eq '/adm/dependencies') {
+ if ($env{'request.course.id'} ne '') {
+ if (ref($args) eq 'HASH') {
+ $url = $args->{'docs_url'};
+ $title = $args->{'docs_title'};
+ $toplevel = $url;
+ unless ($toplevel =~ m{^/}) {
+ $toplevel = "/$url";
+ }
+ ($rem) = ($toplevel =~ m{^(.+/)[^/]+$});
+ if ($toplevel =~ m{^(\Q/uploaded/$cdom/$cnum/portfolio/syllabus\E)}) {
+ $path = $1;
+ } else {
+ ($path) =
+ ($toplevel =~ m{^(\Q/uploaded/$cdom/$cnum/\E(?:docs|supplemental)/(?:default|\d+)/\d+)/});
+ }
+ if ($toplevel=~/^\/*(uploaded|editupload)/) {
+ $fileloc = $toplevel;
+ $fileloc=~ s/^\s*(\S+)\s*$/$1/;
+ my ($udom,$uname,$fname) =
+ ($fileloc=~ m{^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$});
+ $fileloc = propath($udom,$uname).'/userfiles/'.$fname;
+ } else {
+ $fileloc = &Apache::lonnet::filelocation('',$toplevel);
+ }
+ $fileloc =~ s{^/}{};
+ ($filename) = ($fileloc =~ m{.+/([^/]+)$});
+ $heading = &mt('Status of dependencies in [_1]',"$title ($filename)");
+ }
}
- }
- my $now = time();
- foreach my $embed_file (keys(%{$allfiles})) {
- my $absolutepath;
+ } elsif ($actionurl eq "/public/$cdom/$cnum/syllabus") {
+ $udom = $cdom;
+ $uname = $cnum;
+ $url = "/uploaded/$cdom/$cnum/portfolio/syllabus";
+ $toplevel = $url;
+ $path = $url;
+ $fileloc = &Apache::lonnet::filelocation('',$toplevel).'/';
+ $fileloc =~ s{^/}{};
+ }
+ foreach my $file (keys(%{$allfiles})) {
+ my $embed_file;
+ if (($path eq "/uploaded/$cdom/$cnum/portfolio/syllabus") && ($file =~ m{^\Q$path/\E(.+)$})) {
+ $embed_file = $1;
+ } else {
+ $embed_file = $file;
+ }
+ my ($absolutepath,$cleaned_file);
if ($embed_file =~ m{^\w+://}) {
- $newfiles{$embed_file} = 1;
- $mapping{$embed_file} = $embed_file;
+ $cleaned_file = $embed_file;
+ $newfiles{$cleaned_file} = 1;
+ $mapping{$cleaned_file} = $embed_file;
} else {
+ $cleaned_file = &clean_path($embed_file);
if ($embed_file =~ m{^/}) {
$absolutepath = $embed_file;
- $embed_file =~ s{^(/+)}{};
}
- if ($embed_file =~ m{/}) {
- my ($path,$fname) = ($embed_file =~ m{^(.+)/([^/]*)$});
+ if ($cleaned_file =~ m{/}) {
+ my ($path,$fname) = ($cleaned_file =~ m{^(.+)/([^/]*)$});
$path = &check_for_traversal($path,$url,$toplevel);
my $item = $fname;
if ($path ne '') {
@@ -9023,32 +10675,60 @@ sub ask_for_embedded_content {
} else {
$dependencies{$embed_file} = 1;
if ($absolutepath) {
- $mapping{$embed_file} = $absolutepath;
+ $mapping{$cleaned_file} = $absolutepath;
} else {
- $mapping{$embed_file} = $embed_file;
+ $mapping{$cleaned_file} = $embed_file;
}
}
}
}
+ my $dirptr = 16384;
foreach my $path (keys(%subdependencies)) {
- my %currsubfile;
- if (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) {
+ $currsubfile{$path} = {};
+ if (($actionurl eq '/adm/portfolio') ||
+ ($actionurl eq '/adm/coursegrp_portfolio')) {
my ($sublistref,$listerror) =
&Apache::lonnet::dirlist($url.$path,$udom,$uname,$getpropath);
if (ref($sublistref) eq 'ARRAY') {
foreach my $line (@{$sublistref}) {
my ($file_name,$rest) = split(/\&/,$line,2);
- $currsubfile{$file_name} = 1;
+ $currsubfile{$path}{$file_name} = 1;
}
}
} elsif (($actionurl eq '/adm/upload') || ($actionurl eq '/adm/testbank')) {
if (opendir(my $dir,$url.'/'.$path)) {
my @subdir_list = grep(!/^\./,readdir($dir));
- map {$currsubfile{$_} = 1;} @subdir_list;
+ map {$currsubfile{$path}{$_} = 1;} @subdir_list;
+ }
+ } elsif (($actionurl eq '/adm/dependencies') ||
+ (($actionurl eq '/adm/coursedocs') && (ref($args) eq 'HASH') &&
+ ($args->{'context'} eq 'paste')) ||
+ ($actionurl eq "/public/$cdom/$cnum/syllabus")) {
+ if ($env{'request.course.id'} ne '') {
+ my $dir;
+ if ($actionurl eq "/public/$cdom/$cnum/syllabus") {
+ $dir = $fileloc;
+ } else {
+ ($dir) = ($fileloc =~ m{^(.+/)[^/]+$});
+ }
+ if ($dir ne '') {
+ my ($sublistref,$listerror) =
+ &Apache::lonnet::dirlist($dir.$path,$cdom,$cnum,$getpropath,undef,'/');
+ if (ref($sublistref) eq 'ARRAY') {
+ foreach my $line (@{$sublistref}) {
+ my ($file_name,$dom,undef,$testdir,undef,undef,undef,undef,$size,
+ undef,$mtime)=split(/\&/,$line,12);
+ unless (($testdir&$dirptr) ||
+ ($file_name =~ /^\.\.?$/)) {
+ $currsubfile{$path}{$file_name} = [$size,$mtime];
+ }
+ }
+ }
+ }
}
}
foreach my $file (keys(%{$subdependencies{$path}})) {
- if ($currsubfile{$file}) {
+ if (exists($currsubfile{$path}{$file})) {
my $item = $path.'/'.$file;
unless ($mapping{$item} eq $item) {
$pathchanges{$item} = 1;
@@ -9059,9 +10739,27 @@ sub ask_for_embedded_content {
$newfiles{$path.'/'.$file} = 1;
}
}
+ if ($actionurl eq '/adm/dependencies') {
+ foreach my $path (keys(%currsubfile)) {
+ if (ref($currsubfile{$path}) eq 'HASH') {
+ foreach my $file (keys(%{$currsubfile{$path}})) {
+ unless ($subdependencies{$path}{$file}) {
+ next if (($rem ne '') &&
+ (($env{"httpref.$rem"."$path/$file"} ne '') ||
+ (ref($navmap) &&
+ (($navmap->getResourceByUrl($rem."$path/$file") ne '') ||
+ (($file =~ /^(.*\.s?html?)\.bak$/i) &&
+ ($navmap->getResourceByUrl($rem."$path/$1")))))));
+ $unused{$path.'/'.$file} = 1;
+ }
+ }
+ }
+ }
+ }
}
my %currfile;
- if (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) {
+ if (($actionurl eq '/adm/portfolio') ||
+ ($actionurl eq '/adm/coursegrp_portfolio')) {
my ($dirlistref,$listerror) =
&Apache::lonnet::dirlist($url,$udom,$uname,$getpropath);
if (ref($dirlistref) eq 'ARRAY') {
@@ -9075,9 +10773,30 @@ sub ask_for_embedded_content {
my @dir_list = grep(!/^\./,readdir($dir));
map {$currfile{$_} = 1;} @dir_list;
}
+ } elsif (($actionurl eq '/adm/dependencies') ||
+ (($actionurl eq '/adm/coursedocs') && (ref($args) eq 'HASH') &&
+ ($args->{'context'} eq 'paste')) ||
+ ($actionurl eq "/public/$cdom/$cnum/syllabus")) {
+ if ($env{'request.course.id'} ne '') {
+ my ($dir) = ($fileloc =~ m{^(.+/)[^/]+$});
+ if ($dir ne '') {
+ my ($dirlistref,$listerror) =
+ &Apache::lonnet::dirlist($dir,$cdom,$cnum,$getpropath,undef,'/');
+ if (ref($dirlistref) eq 'ARRAY') {
+ foreach my $line (@{$dirlistref}) {
+ my ($file_name,$dom,undef,$testdir,undef,undef,undef,undef,
+ $size,undef,$mtime)=split(/\&/,$line,12);
+ unless (($testdir&$dirptr) ||
+ ($file_name =~ /^\.\.?$/)) {
+ $currfile{$file_name} = [$size,$mtime];
+ }
+ }
+ }
+ }
+ }
}
foreach my $file (keys(%dependencies)) {
- if ($currfile{$file}) {
+ if (exists($currfile{$file})) {
unless ($mapping{$file} eq $file) {
$pathchanges{$file} = 1;
}
@@ -9087,41 +10806,137 @@ sub ask_for_embedded_content {
$newfiles{$file} = 1;
}
}
+ foreach my $file (keys(%currfile)) {
+ unless (($file eq $filename) ||
+ ($file eq $filename.'.bak') ||
+ ($dependencies{$file})) {
+ if ($actionurl eq '/adm/dependencies') {
+ unless ($toplevel =~ m{^\Q/uploaded/$cdom/$cnum/portfolio/syllabus\E}) {
+ next if (($rem ne '') &&
+ (($env{"httpref.$rem".$file} ne '') ||
+ (ref($navmap) &&
+ (($navmap->getResourceByUrl($rem.$file) ne '') ||
+ (($file =~ /^(.*\.s?html?)\.bak$/i) &&
+ ($navmap->getResourceByUrl($rem.$1)))))));
+ }
+ }
+ $unused{$file} = 1;
+ }
+ }
+ if (($actionurl eq '/adm/coursedocs') && (ref($args) eq 'HASH') &&
+ ($args->{'context'} eq 'paste')) {
+ $counter = scalar(keys(%existing));
+ $numpathchg = scalar(keys(%pathchanges));
+ return ($output,$counter,$numpathchg,\%existing);
+ } elsif (($actionurl eq "/public/$cdom/$cnum/syllabus") &&
+ (ref($args) eq 'HASH') && ($args->{'context'} eq 'rewrites')) {
+ $counter = scalar(keys(%existing));
+ $numpathchg = scalar(keys(%pathchanges));
+ return ($output,$counter,$numpathchg,\%existing,\%mapping);
+ }
foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%newfiles)) {
+ if ($actionurl eq '/adm/dependencies') {
+ next if ($embed_file =~ m{^\w+://});
+ }
$upload_output .= &start_data_table_row().
- '
';
}
+ if ($context eq 'syllabus') {
+ unless ($saveresult eq 'ok') {
+ $skiprewrites = 1;
+ }
+ }
} else {
if (open(my $fh,">$container")) {
print $fh $content;
@@ -9548,12 +11526,57 @@ sub modify_html_refs {
}
}
}
+ if (($context eq 'syllabus') && (!$skiprewrites)) {
+ my ($actionurl,$state);
+ $actionurl = "/public/$udom/$uname/syllabus";
+ my ($ignore,$num,$numpathchanges,$existing,$mapping) =
+ &ask_for_embedded_content($actionurl,$state,\%allfiles,
+ \%codebase,
+ {'context' => 'rewrites',
+ 'ignore_remote_references' => 1,});
+ if (ref($mapping) eq 'HASH') {
+ my $rewrites = 0;
+ foreach my $key (keys(%{$mapping})) {
+ next if ($key =~ m{^https?://});
+ my $ref = $mapping->{$key};
+ my $newname = "/uploaded/$udom/$uname/portfolio/syllabus/$key";
+ my $attrib;
+ if (ref($allfiles{$mapping->{$key}}) eq 'ARRAY') {
+ $attrib = join('|',@{$allfiles{$mapping->{$key}}});
+ }
+ if ($content =~ m{($attrib\s*=\s*['"]?)\Q$ref\E(['"]?)}) {
+ my $numchg = ($content =~ s{($attrib\s*=\s*['"]?)\Q$ref\E(['"]?)}{$1$newname$2}gi);
+ $rewrites += $numchg;
+ }
+ }
+ if ($rewrites) {
+ my $saveresult;
+ my $url = &Apache::lonnet::store_edited_file($container,$content,$udom,$uname,\$saveresult);
+ if ($url eq $container) {
+ my ($fname) = ($container =~ m{/([^/]+)$});
+ $output .= '
'.&mt('Rewrote [quant,_1,link] as [quant,_1,absolute link] in [_2].',
+ $count,''.
+ $fname.'').'
';
+ } else {
+ $output .= '
'.
+ &mt('Error: could not update links in [_1].',
+ ''.
+ $container.'').'
';
+
+ }
+ }
+ }
+ }
} else {
&logthis('Failed to parse '.$container.
' to modify references: '.$parse_result);
}
}
- return $output;
+ if (wantarray) {
+ return ($output,$count,$codebasecount);
+ } else {
+ return $output;
+ }
}
sub check_for_existing {
@@ -9633,11 +11656,11 @@ sub check_for_upload {
if ($currsize < $filesize) {
my $extra = $filesize - $currsize;
if (($current_disk_usage + $extra) > $disk_quota) {
- my $msg = ''.
+ my $msg = '
'.
&mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded if existing (smaller) file with same name (size = [_3] kilobytes) is replaced.',
- ''.$fname.'',$filesize,$currsize).'
'.
- ' '.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',
- $disk_quota,$current_disk_usage);
+ ''.$fname.'',$filesize,$currsize).''.
+ '
'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',
+ $disk_quota,$current_disk_usage).'
';
return ('will_exceed_quota',$msg);
}
}
@@ -9646,21 +11669,21 @@ sub check_for_upload {
}
}
if (($current_disk_usage + $filesize) > $disk_quota){
- my $msg = ''.
- &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.',''.$fname.'',$filesize).''.
- ' '.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',$disk_quota,$current_disk_usage);
+ my $msg = '
'.
+ &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.',''.$fname.'',$filesize).'
'.
+ '
'.&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 = '';
+ my $msg = '
';
$msg .= &mt('Unable to upload [_1]. A locked file by that name was found in [_2].',''.$fname.'',''.$port_path.$env{'form.currentpath'}.'');
- $msg .= '
';
+ $msg .= '';
$msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.',''.$fname.'');
return ('file_locked',$msg);
} else {
- my $msg = '';
+ my $msg = '
';
$msg .= &mt(' A file by that name: [_1] was found in [_2].',''.$fname.'',$port_path.$env{'form.currentpath'});
- $msg .= '
';
+ $msg .= '';
return ('existingfile',$msg);
}
}
@@ -9709,6 +11732,1225 @@ sub check_for_traversal {
return $cleanpath;
}
+sub is_archive_file {
+ my ($mimetype) = @_;
+ if (($mimetype eq 'application/octet-stream') ||
+ ($mimetype eq 'application/x-stuffit') ||
+ ($mimetype =~ m{^application/(x\-)?(compressed|tar|zip|tgz|gz|gtar|gzip|gunzip|bz|bz2|bzip2)})) {
+ return 1;
+ }
+ return;
+}
+
+sub decompress_form {
+ my ($mimetype,$archiveurl,$action,$noextract,$hiddenelements,$dirlist) = @_;
+ my %lt = &Apache::lonlocal::texthash (
+ this => 'This file is an archive file.',
+ camt => 'This file is a Camtasia archive file.',
+ itsc => 'Its contents are as follows:',
+ youm => 'You may wish to extract its contents.',
+ extr => 'Extract contents',
+ auto => 'LON-CAPA can process the files automatically, or you can decide how each should be handled.',
+ proa => 'Process automatically?',
+ yes => 'Yes',
+ no => 'No',
+ fold => 'Title for folder containing movie',
+ movi => 'Title for page containing embedded movie',
+ );
+ my $fileloc = &Apache::lonnet::filelocation(undef,$archiveurl);
+ my ($is_camtasia,$topdir,%toplevel,@paths);
+ my $info = &list_archive_contents($fileloc,\@paths);
+ if (@paths) {
+ foreach my $path (@paths) {
+ $path =~ s{^/}{};
+ if ($path =~ m{^([^/]+)/$}) {
+ $topdir = $1;
+ }
+ if ($path =~ m{^([^/]+)/}) {
+ $toplevel{$1} = $path;
+ } else {
+ $toplevel{$path} = $path;
+ }
+ }
+ }
+ if ($mimetype =~ m{^application/(x\-)?(compressed|zip)}) {
+ my @camtasia6 = ("$topdir/","$topdir/index.html",
+ "$topdir/media/",
+ "$topdir/media/$topdir.mp4",
+ "$topdir/media/FirstFrame.png",
+ "$topdir/media/player.swf",
+ "$topdir/media/swfobject.js",
+ "$topdir/media/expressInstall.swf");
+ my @camtasia8_1 = ("$topdir/","$topdir/$topdir.html",
+ "$topdir/$topdir.mp4",
+ "$topdir/$topdir\_config.xml",
+ "$topdir/$topdir\_controller.swf",
+ "$topdir/$topdir\_embed.css",
+ "$topdir/$topdir\_First_Frame.png",
+ "$topdir/$topdir\_player.html",
+ "$topdir/$topdir\_Thumbnails.png",
+ "$topdir/playerProductInstall.swf",
+ "$topdir/scripts/",
+ "$topdir/scripts/config_xml.js",
+ "$topdir/scripts/handlebars.js",
+ "$topdir/scripts/jquery-1.7.1.min.js",
+ "$topdir/scripts/jquery-ui-1.8.15.custom.min.js",
+ "$topdir/scripts/modernizr.js",
+ "$topdir/scripts/player-min.js",
+ "$topdir/scripts/swfobject.js",
+ "$topdir/skins/",
+ "$topdir/skins/configuration_express.xml",
+ "$topdir/skins/express_show/",
+ "$topdir/skins/express_show/player-min.css",
+ "$topdir/skins/express_show/spritesheet.png");
+ my @camtasia8_4 = ("$topdir/","$topdir/$topdir.html",
+ "$topdir/$topdir.mp4",
+ "$topdir/$topdir\_config.xml",
+ "$topdir/$topdir\_controller.swf",
+ "$topdir/$topdir\_embed.css",
+ "$topdir/$topdir\_First_Frame.png",
+ "$topdir/$topdir\_player.html",
+ "$topdir/$topdir\_Thumbnails.png",
+ "$topdir/playerProductInstall.swf",
+ "$topdir/scripts/",
+ "$topdir/scripts/config_xml.js",
+ "$topdir/scripts/techsmith-smart-player.min.js",
+ "$topdir/skins/",
+ "$topdir/skins/configuration_express.xml",
+ "$topdir/skins/express_show/",
+ "$topdir/skins/express_show/spritesheet.min.css",
+ "$topdir/skins/express_show/spritesheet.png",
+ "$topdir/skins/express_show/techsmith-smart-player.min.css");
+ my @diffs = &compare_arrays(\@paths,\@camtasia6);
+ if (@diffs == 0) {
+ $is_camtasia = 6;
+ } else {
+ @diffs = &compare_arrays(\@paths,\@camtasia8_1);
+ if (@diffs == 0) {
+ $is_camtasia = 8;
+ } else {
+ @diffs = &compare_arrays(\@paths,\@camtasia8_4);
+ if (@diffs == 0) {
+ $is_camtasia = 8;
+ }
+ }
+ }
+ }
+ my $output;
+ if ($is_camtasia) {
+ $output = <<"ENDCAM";
+
+
'.&end_page();
+ return $output;
+}
+
+=pod
+
+=item * &needs_coursereinit()
+
+Determine if course contents stored for user's session needs to be
+refreshed, because content has changed since "Big Hash" last tied.
+
+Check for change is made if time last checked is more than 10 minutes ago
+(by default).
+
+Inputs:
+
+$loncaparev - Version on current server (format: Major.Minor.Subrelease-datestamp)
+
+$interval (optional) - Time which may elapse (in s) between last check for content
+ change in current course. (default: 600 s).
+
+Returns: an array; first element is:
+
+=over 4
+
+'switch' - if content updates mean user's session
+ needs to be switched to a server running a newer LON-CAPA version
+
+'update' - if course session needs to be refreshed (i.e., Big Hash needs to be reloaded)
+ on current server hosting user's session
+
+'' - if no action required.
+
+=back
+
+If first item element is 'switch':
+
+second item is $switchwarning - Warning message if no suitable server found to host session.
+
+third item is $switchserver - query string to append to /adm/switchserver containing lonHostID
+ and current role.
+
+otherwise: no other elements returned.
+
+=back
+
=cut
+sub needs_coursereinit {
+ my ($loncaparev,$interval) = @_;
+ return() unless ($env{'request.course.id'} && $env{'request.course.tied'});
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ my $now = time;
+ if ($interval eq '') {
+ $interval = 600;
+ }
+ if (($now-$env{'request.course.timechecked'})>$interval) {
+ my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
+ &Apache::lonnet::appenv({'request.course.timechecked'=>$now});
+ if ($lastchange > $env{'request.course.tied'}) {
+ my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
+ if ($curr_reqd_hash{'internal.releaserequired'} ne '') {
+ my $required = $env{'course.'.$cdom.'_'.$cnum.'.internal.releaserequired'};
+ if ($curr_reqd_hash{'internal.releaserequired'} ne $required) {
+ &Apache::lonnet::appenv({'course.'.$cdom.'_'.$cnum.'.internal.releaserequired' =>
+ $curr_reqd_hash{'internal.releaserequired'}});
+ my ($switchserver,$switchwarning) =
+ &check_release_required($loncaparev,$cdom.'_'.$cnum,$env{'request.role'},
+ $curr_reqd_hash{'internal.releaserequired'});
+ if ($switchwarning ne '' || $switchserver ne '') {
+ return ('switch',$switchwarning,$switchserver);
+ }
+ }
+ }
+ return ('update');
+ }
+ }
+ return ();
+}
+
+sub update_content_constraints {
+ my ($cdom,$cnum,$chome,$cid) = @_;
+ my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
+ my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
+ my %checkresponsetypes;
+ foreach my $key (keys(%Apache::lonnet::needsrelease)) {
+ my ($item,$name,$value,$valmatch) = split(/:/,$key);
+ if ($item eq 'resourcetag') {
+ if ($name eq 'responsetype') {
+ $checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key}
+ }
+ }
+ }
+ my $navmap = Apache::lonnavmaps::navmap->new();
+ if (defined($navmap)) {
+ my %allresponses;
+ foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) {
+ my %responses = $res->responseTypes();
+ foreach my $key (keys(%responses)) {
+ next unless(exists($checkresponsetypes{$key}));
+ $allresponses{$key} += $responses{$key};
+ }
+ }
+ foreach my $key (keys(%allresponses)) {
+ my ($major,$minor) = split(/\./,$checkresponsetypes{$key});
+ if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) {
+ ($reqdmajor,$reqdminor) = ($major,$minor);
+ }
+ }
+ undef($navmap);
+ }
+ unless (($reqdmajor eq '') && ($reqdminor eq '')) {
+ &Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid);
+ }
+ return;
+}
+
+sub allmaps_incourse {
+ my ($cdom,$cnum,$chome,$cid) = @_;
+ if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') {
+ $cid = $env{'request.course.id'};
+ $cdom = $env{'course.'.$cid.'.domain'};
+ $cnum = $env{'course.'.$cid.'.num'};
+ $chome = $env{'course.'.$cid.'.home'};
+ }
+ my %allmaps = ();
+ my $lastchange =
+ &Apache::lonnet::get_coursechange($cdom,$cnum);
+ if ($lastchange > $env{'request.course.tied'}) {
+ my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum");
+ unless ($ferr) {
+ &update_content_constraints($cdom,$cnum,$chome,$cid);
+ }
+ }
+ my $navmap = Apache::lonnavmaps::navmap->new();
+ if (defined($navmap)) {
+ foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_map() },1,0,1)) {
+ $allmaps{$res->src()} = 1;
+ }
+ }
+ return \%allmaps;
+}
+
+sub parse_supplemental_title {
+ my ($title) = @_;
+
+ my ($foldertitle,$renametitle);
+ if ($title =~ /&&&/) {
+ $title = &HTML::Entites::decode($title);
+ }
+ if ($title =~ m/^(\d+)___&&&___($match_username)___&&&___($match_domain)___&&&___(.*)$/) {
+ $renametitle=$4;
+ my ($time,$uname,$udom) = ($1,$2,$3);
+ $foldertitle=&Apache::lontexconvert::msgtexconverted($4);
+ my $name = &plainname($uname,$udom);
+ $name = &HTML::Entities::encode($name,'"<>&\'');
+ $renametitle = &HTML::Entities::encode($renametitle,'"<>&\'');
+ $title=''.&Apache::lonlocal::locallocaltime($time).' '.
+ $name.': '.$foldertitle;
+ }
+ if (wantarray) {
+ return ($title,$foldertitle,$renametitle);
+ }
+ return $title;
+}
+
+sub recurse_supplemental {
+ my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_;
+ if ($suppmap) {
+ my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap);
+ if ($fatal) {
+ $errors ++;
+ } else {
+ if ($#LONCAPA::map::resources > 0) {
+ foreach my $res (@LONCAPA::map::resources) {
+ my ($title,$src,$ext,$type,$status)=split(/\:/,$res);
+ if (($src ne '') && ($status eq 'res')) {
+ if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) {
+ ($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors);
+ } else {
+ $numfiles ++;
+ }
+ }
+ }
+ }
+ }
+ }
+ return ($numfiles,$errors);
+}
+
+sub symb_to_docspath {
+ my ($symb) = @_;
+ return unless ($symb);
+ my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb);
+ if ($resurl=~/\.(sequence|page)$/) {
+ $mapurl=$resurl;
+ } elsif ($resurl eq 'adm/navmaps') {
+ $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'};
+ }
+ my $mapresobj;
+ my $navmap = Apache::lonnavmaps::navmap->new();
+ if (ref($navmap)) {
+ $mapresobj = $navmap->getResourceByUrl($mapurl);
+ }
+ $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1};
+ my $type=$2;
+ my $path;
+ if (ref($mapresobj)) {
+ my $pcslist = $mapresobj->map_hierarchy();
+ if ($pcslist ne '') {
+ foreach my $pc (split(/,/,$pcslist)) {
+ next if ($pc <= 1);
+ my $res = $navmap->getByMapPc($pc);
+ if (ref($res)) {
+ my $thisurl = $res->src();
+ $thisurl=~s{^.*/([^/]+)\.\w+$}{$1};
+ my $thistitle = $res->title();
+ $path .= '&'.
+ &Apache::lonhtmlcommon::entity_encode($thisurl).'&'.
+ &escape($thistitle).
+ ':'.$res->randompick().
+ ':'.$res->randomout().
+ ':'.$res->encrypted().
+ ':'.$res->randomorder().
+ ':'.$res->is_page();
+ }
+ }
+ }
+ $path =~ s/^\&//;
+ my $maptitle = $mapresobj->title();
+ if ($mapurl eq 'default') {
+ $maptitle = 'Main Content';
+ }
+ $path .= (($path ne '')? '&' : '').
+ &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.
+ &escape($maptitle).
+ ':'.$mapresobj->randompick().
+ ':'.$mapresobj->randomout().
+ ':'.$mapresobj->encrypted().
+ ':'.$mapresobj->randomorder().
+ ':'.$mapresobj->is_page();
+ } else {
+ my $maptitle = &Apache::lonnet::gettitle($mapurl);
+ my $ispage = (($type eq 'page')? 1 : '');
+ if ($mapurl eq 'default') {
+ $maptitle = 'Main Content';
+ }
+ $path = &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.
+ &escape($maptitle).':::::'.$ispage;
+ }
+ unless ($mapurl eq 'default') {
+ $path = 'default&'.
+ &escape('Main Content').
+ ':::::&'.$path;
+ }
+ return $path;
+}
+
+sub captcha_display {
+ my ($context,$lonhost) = @_;
+ my ($output,$error);
+ my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost);
+ if ($captcha eq 'original') {
+ $output = &create_captcha();
+ unless ($output) {
+ $error = 'captcha';
+ }
+ } elsif ($captcha eq 'recaptcha') {
+ $output = &create_recaptcha($pubkey);
+ unless ($output) {
+ $error = 'recaptcha';
+ }
+ }
+ return ($output,$error,$captcha);
+}
+
+sub captcha_response {
+ my ($context,$lonhost) = @_;
+ my ($captcha_chk,$captcha_error);
+ my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost);
+ if ($captcha eq 'original') {
+ ($captcha_chk,$captcha_error) = &check_captcha();
+ } elsif ($captcha eq 'recaptcha') {
+ $captcha_chk = &check_recaptcha($privkey);
+ } else {
+ $captcha_chk = 1;
+ }
+ return ($captcha_chk,$captcha_error);
+}
+
+sub get_captcha_config {
+ my ($context,$lonhost) = @_;
+ my ($captcha,$pubkey,$privkey,$hashtocheck);
+ my $hostname = &Apache::lonnet::hostname($lonhost);
+ my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);
+ my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
+ if ($context eq 'usercreation') {
+ my %domconfig = &Apache::lonnet::get_dom('configuration',[$context],$serverhomedom);
+ if (ref($domconfig{$context}) eq 'HASH') {
+ $hashtocheck = $domconfig{$context}{'cancreate'};
+ if (ref($hashtocheck) eq 'HASH') {
+ if ($hashtocheck->{'captcha'} eq 'recaptcha') {
+ if (ref($hashtocheck->{'recaptchakeys'}) eq 'HASH') {
+ $pubkey = $hashtocheck->{'recaptchakeys'}{'public'};
+ $privkey = $hashtocheck->{'recaptchakeys'}{'private'};
+ }
+ if ($privkey && $pubkey) {
+ $captcha = 'recaptcha';
+ } else {
+ $captcha = 'original';
+ }
+ } elsif ($hashtocheck->{'captcha'} ne 'notused') {
+ $captcha = 'original';
+ }
+ }
+ } else {
+ $captcha = 'captcha';
+ }
+ } elsif ($context eq 'login') {
+ my %domconfhash = &Apache::loncommon::get_domainconf($serverhomedom);
+ if ($domconfhash{$serverhomedom.'.login.captcha'} eq 'recaptcha') {
+ $pubkey = $domconfhash{$serverhomedom.'.login.recaptchakeys_public'};
+ $privkey = $domconfhash{$serverhomedom.'.login.recaptchakeys_private'};
+ if ($privkey && $pubkey) {
+ $captcha = 'recaptcha';
+ } else {
+ $captcha = 'original';
+ }
+ } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {
+ $captcha = 'original';
+ }
+ }
+ return ($captcha,$pubkey,$privkey);
+}
+
+sub create_captcha {
+ my %captcha_params = &captcha_settings();
+ my ($output,$maxtries,$tries) = ('',10,0);
+ while ($tries < $maxtries) {
+ $tries ++;
+ my $captcha = Authen::Captcha->new (
+ output_folder => $captcha_params{'output_dir'},
+ data_folder => $captcha_params{'db_dir'},
+ );
+ my $md5sum = $captcha->generate_code($captcha_params{'numchars'});
+
+ if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') {
+ $output = ''."\n".
+ &mt('Type in the letters/numbers shown below').' '.
+ ''.
+ ' '.
+ '';
+ last;
+ }
+ }
+ return $output;
+}
+
+sub captcha_settings {
+ my %captcha_params = (
+ output_dir => $Apache::lonnet::perlvar{'lonCaptchaDir'},
+ www_output_dir => "/captchaspool",
+ db_dir => $Apache::lonnet::perlvar{'lonCaptchaDb'},
+ numchars => '5',
+ );
+ return %captcha_params;
+}
+
+sub check_captcha {
+ my ($captcha_chk,$captcha_error);
+ my $code = $env{'form.code'};
+ my $md5sum = $env{'form.crypt'};
+ my %captcha_params = &captcha_settings();
+ my $captcha = Authen::Captcha->new(
+ output_folder => $captcha_params{'output_dir'},
+ data_folder => $captcha_params{'db_dir'},
+ );
+ $captcha_chk = $captcha->check_code($code,$md5sum);
+ my %captcha_hash = (
+ 0 => 'Code not checked (file error)',
+ -1 => 'Failed: code expired',
+ -2 => 'Failed: invalid code (not in database)',
+ -3 => 'Failed: invalid code (code does not match crypt)',
+ );
+ if ($captcha_chk != 1) {
+ $captcha_error = $captcha_hash{$captcha_chk}
+ }
+ return ($captcha_chk,$captcha_error);
+}
+
+sub create_recaptcha {
+ my ($pubkey) = @_;
+ my $use_ssl;
+ if ($ENV{'SERVER_PORT'} == 443) {
+ $use_ssl = 1;
+ }
+ my $captcha = Captcha::reCAPTCHA->new;
+ return $captcha->get_options_setter({theme => 'white'})."\n".
+ $captcha->get_html($pubkey,undef,$use_ssl).
+ &mt('If the text is hard to read, [_1] will replace them.',
+ '').
+ '
';
+}
+
+sub check_recaptcha {
+ my ($privkey) = @_;
+ my $captcha_chk;
+ my $captcha = Captcha::reCAPTCHA->new;
+ my $captcha_result =
+ $captcha->check_answer(
+ $privkey,
+ $ENV{'REMOTE_ADDR'},
+ $env{'form.recaptcha_challenge_field'},
+ $env{'form.recaptcha_response_field'},
+ );
+ if ($captcha_result->{is_valid}) {
+ $captcha_chk = 1;
+ }
+ return $captcha_chk;
+}
+
+sub emailusername_info {
+ my @fields = ('firstname','lastname','institution','web','location','officialemail');
+ my %titles = &Apache::lonlocal::texthash (
+ lastname => 'Last Name',
+ firstname => 'First Name',
+ institution => 'School/college/university',
+ location => "School's city, state/province, country",
+ web => "School's web address",
+ officialemail => 'E-mail address at institution (if different)',
+ );
+ return (\@fields,\%titles);
+}
+
+sub cleanup_html {
+ my ($incoming) = @_;
+ my $outgoing;
+ if ($incoming ne '') {
+ $outgoing = $incoming;
+ $outgoing =~ s/;/;/g;
+ $outgoing =~ s/\#/#/g;
+ $outgoing =~ s/\&/&/g;
+ $outgoing =~ s/</g;
+ $outgoing =~ s/>/>/g;
+ $outgoing =~ s/\(/(/g;
+ $outgoing =~ s/\)/)/g;
+ $outgoing =~ s/"/"/g;
+ $outgoing =~ s/'/'/g;
+ $outgoing =~ s/\$/$/g;
+ $outgoing =~ s{/}{/}g;
+ $outgoing =~ s/=/=/g;
+ $outgoing =~ s/\\/\/g
+ }
+ return $outgoing;
+}
+
+# Checks for critical messages and returns a redirect url if one exists.
+# $interval indicates how often to check for messages.
+sub critical_redirect {
+ my ($interval) = @_;
+ if ((time-$env{'user.criticalcheck.time'})>$interval) {
+ my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},
+ $env{'user.name'});
+ &Apache::lonnet::appenv({'user.criticalcheck.time'=>time});
+ my $redirecturl;
+ if ($what[0]) {
+ if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) {
+ $redirecturl='/adm/email?critical=display';
+ my $url=&Apache::lonnet::absolute_url().$redirecturl;
+ return (1, $url);
+ }
+ }
+ }
+ return ();
+}
+
+# Use:
+# my $answer=reply("encrypt:passwd:$udom:$uname:$upass",$tryserver);
+#
+##################################################
+# password associated functions #
+##################################################
+sub des_keys {
+ # Make a new key for DES encryption.
+ # Each key has two parts which are returned separately.
+ # Please note: Each key must be passed through the &hex function
+ # before it is output to the web browser. The hex versions cannot
+ # be used to decrypt.
+ my @hexstr=('0','1','2','3','4','5','6','7',
+ '8','9','a','b','c','d','e','f');
+ my $lkey='';
+ for (0..7) {
+ $lkey.=$hexstr[rand(15)];
+ }
+ my $ukey='';
+ for (0..7) {
+ $ukey.=$hexstr[rand(15)];
+ }
+ return ($lkey,$ukey);
+}
+
+sub des_decrypt {
+ my ($key,$cyphertext) = @_;
+ my $keybin=pack("H16",$key);
+ my $cypher;
+ if ($Crypt::DES::VERSION>=2.03) {
+ $cypher=new Crypt::DES $keybin;
+ } else {
+ $cypher=new DES $keybin;
+ }
+ my $plaintext='';
+ my $cypherlength = length($cyphertext);
+ my $numchunks = int($cypherlength/32);
+ for (my $j=0; $j<$numchunks; $j++) {
+ my $start = $j*32;
+ my $cypherblock = substr($cyphertext,$start,32);
+ my $chunk =
+ $cypher->decrypt(unpack("a8",pack("H16",substr($cypherblock,0,16))));
+ $chunk .=
+ $cypher->decrypt(unpack("a8",pack("H16",substr($cypherblock,16,16))));
+ $chunk=substr($chunk,1,ord(substr($chunk,0,1)) );
+ $plaintext .= $chunk;
+ }
+ return $plaintext;
+}
+
1;
__END__;
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.