'.&mt('Updated [quant,_1,reference] in [_2].',
$count,''.
- $fname.' ').'
';
+ $fname.'').'';
} else {
$output = ''.
&mt('Error: update failed for: [_1].',
''.
$container.' ').'
';
}
+ if ($context eq 'syllabus') {
+ unless ($saveresult eq 'ok') {
+ $skiprewrites = 1;
+ }
+ }
} else {
- if (open(my $fh,">$container")) {
+ if (open(my $fh,'>',$container)) {
print $fh $content;
close($fh);
$output = ''.&mt('Updated [quant,_1,reference] in [_2].',
@@ -9757,12 +11584,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 {
@@ -9842,11 +11714,11 @@ sub check_for_upload {
if ($currsize < $filesize) {
my $extra = $filesize - $currsize;
if (($current_disk_usage + $extra) > $disk_quota) {
- my $msg = ''.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',
+ $disk_quota,$current_disk_usage).'
';
return ('will_exceed_quota',$msg);
}
}
@@ -9855,21 +11727,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).'
';
return ('will_exceed_quota',$msg);
} elsif ($found_file) {
if ($locked_file) {
- my $msg = ''."\n";
+ $result .= ''.&mt('Folder: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"')).
+ ' '."\n";
}
}
} else {
@@ -10830,116 +12787,138 @@ sub process_extracted_files {
my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.
$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.
$title;
- if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
- mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
- }
- if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
- mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
- }
- if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
- system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title");
- $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
- unless ($ishome) {
- my $fetch = "$newdest{$i}/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
+ if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) {
+ if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
+ mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
}
- }
- $LONCAPA::map::resources[$newidx]=
- $docstitle.':'.$url.':false:normal:res';
- push(@LONCAPA::map::order, $newidx);
- my ($outtext,$errtext)=
- &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
- $docuname.'/'.$folders{$outer}.
- '.'.$containers{$outer},1);
- unless ($errtext) {
- if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
- $result .= ''.&mt('File: [_1] added to course',$docstitle).' '."\n";
+ if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
+ mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
+ }
+ if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
+ if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) {
+ $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
+ unless ($ishome) {
+ my $fetch = "$newdest{$i}/$title";
+ $fetch =~ s/^\Q$prefix$dir\E//;
+ $prompttofetch{$fetch} = 1;
+ }
+ }
}
+ $LONCAPA::map::resources[$newidx]=
+ $docstitle.':'.$url.':false:normal:res';
+ push(@LONCAPA::map::order, $newidx);
+ my ($outtext,$errtext)=
+ &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
+ $docuname.'/'.$folders{$outer}.
+ '.'.$containers{$outer},1,1);
+ unless ($errtext) {
+ if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
+ $result .= ''.&mt('File: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"')).
+ ' '."\n";
+ }
+ }
+ } else {
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).' ';
}
}
}
- } elsif ($env{'form.archive_'.$i} eq 'dependency') {
- my ($title) = ($path =~ m{/([^/]+)$});
- $referrer{$i} = $env{'form.archive_dependent_on_'.$i};
- if ($env{'form.archive_'.$referrer{$i}} eq 'display') {
- if (ref($dirorder{$i}) eq 'ARRAY') {
- my ($itemidx,$fullpath,$relpath);
+ }
+ } else {
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).' ';
+ }
+ }
+ for (my $i=1; $i<=$numitems; $i++) {
+ next unless ($env{'form.archive_'.$i} eq 'dependency');
+ my $path = $env{'form.archive_content_'.$i};
+ if ($path =~ /^\Q$pathtocheck\E/) {
+ my ($title) = ($path =~ m{/([^/]+)$});
+ $referrer{$i} = $env{'form.archive_dependent_on_'.$i};
+ if ($env{'form.archive_'.$referrer{$i}} eq 'display') {
+ if (ref($dirorder{$i}) eq 'ARRAY') {
+ my ($itemidx,$fullpath,$relpath);
+ if (ref($dirorder{$referrer{$i}}) eq 'ARRAY') {
+ my $container = $dirorder{$referrer{$i}}->[-1];
for (my $j=0; $j<@{$dirorder{$i}}; $j++) {
- if (ref($dirorder{$referrer{$i}}) eq 'ARRAY') {
- my $container = $dirorder{$referrer{$i}}->[-1];
- for (my $j=0; $j<@{$dirorder{$i}}; $j++) {
- if ($dirorder{$i}->[$j] eq $container) {
- $itemidx = $j;
- }
- }
+ if ($dirorder{$i}->[$j] eq $container) {
+ $itemidx = $j;
}
}
- if ($itemidx ne '') {
- if (grep(/^\Q$referrer{$i}\E$/,@archdirs)) {
- if ($mapinner{$referrer{$i}}) {
- $fullpath = "$prefix$dir/$docstype/$mapinner{$referrer{$i}}";
- for (my $j=$itemidx; $j<@{$dirorder{$i}}; $j++) {
- if (grep(/^\Q$dirorder{$i}->[$j]\E$/,@archdirs)) {
- unless (defined($newseqid{$dirorder{$i}->[$j]})) {
- $fullpath .= '/'.$titles{$dirorder{$i}->[$j]};
- $relpath .= '/'.$titles{$dirorder{$i}->[$j]};
- if (!-e $fullpath) {
- mkdir($fullpath,0755);
- }
- }
- } else {
- last;
+ }
+ if ($itemidx eq '') {
+ $itemidx = 0;
+ }
+ if (grep(/^\Q$referrer{$i}\E$/,@archdirs)) {
+ if ($mapinner{$referrer{$i}}) {
+ $fullpath = "$prefix$dir/$docstype/$mapinner{$referrer{$i}}";
+ for (my $j=$itemidx; $j<@{$dirorder{$i}}; $j++) {
+ if (grep(/^\Q$dirorder{$i}->[$j]\E$/,@archdirs)) {
+ unless (defined($newseqid{$dirorder{$i}->[$j]})) {
+ $fullpath .= '/'.$titles{$dirorder{$i}->[$j]};
+ $relpath .= '/'.$titles{$dirorder{$i}->[$j]};
+ if (!-e $fullpath) {
+ mkdir($fullpath,0755);
}
}
+ } else {
+ last;
}
- } elsif ($newdest{$referrer{$i}}) {
- $fullpath = $newdest{$referrer{$i}};
- for (my $j=$itemidx; $j<@{$dirorder{$i}}; $j++) {
- if ($env{'form.archive_'.$dirorder{$i}->[$j]} eq 'discard') {
- $orphaned{$i} = $env{'form.archive_'.$dirorder{$i}->[$j]};
- last;
- } elsif (grep(/^\Q$dirorder{$i}->[$j]\E$/,@archdirs)) {
- unless (defined($newseqid{$dirorder{$i}->[$j]})) {
- $fullpath .= '/'.$titles{$dirorder{$i}->[$j]};
- $relpath .= '/'.$titles{$dirorder{$i}->[$j]};
- if (!-e $fullpath) {
- mkdir($fullpath,0755);
- }
- }
- } else {
- last;
+ }
+ }
+ } elsif ($newdest{$referrer{$i}}) {
+ $fullpath = $newdest{$referrer{$i}};
+ for (my $j=$itemidx; $j<@{$dirorder{$i}}; $j++) {
+ if ($env{'form.archive_'.$dirorder{$i}->[$j]} eq 'discard') {
+ $orphaned{$i} = $env{'form.archive_'.$dirorder{$i}->[$j]};
+ last;
+ } elsif (grep(/^\Q$dirorder{$i}->[$j]\E$/,@archdirs)) {
+ unless (defined($newseqid{$dirorder{$i}->[$j]})) {
+ $fullpath .= '/'.$titles{$dirorder{$i}->[$j]};
+ $relpath .= '/'.$titles{$dirorder{$i}->[$j]};
+ if (!-e $fullpath) {
+ mkdir($fullpath,0755);
}
}
+ } else {
+ last;
}
- if ($fullpath ne '') {
- if (-e "$prefix$path") {
- system("mv $prefix$path $fullpath/$title");
- }
- if (-e "$fullpath/$title") {
- my $showpath;
- if ($relpath ne '') {
- $showpath = "$relpath/$title";
- } else {
- $showpath = "/$title";
- }
- $result .= ''.&mt('[_1] included as a dependency',$showpath).' '."\n";
- }
- unless ($ishome) {
- my $fetch = "$fullpath/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
- }
+ }
+ }
+ if ($fullpath ne '') {
+ if (-e "$prefix$path") {
+ unless (rename("$prefix$path","$fullpath/$title")) {
+ $warning .= &mt('Failed to rename dependency').' ';
}
}
+ if (-e "$fullpath/$title") {
+ my $showpath;
+ if ($relpath ne '') {
+ $showpath = "$relpath/$title";
+ } else {
+ $showpath = "/$title";
+ }
+ $result .= ''.&mt('[_1] included as a dependency',
+ &HTML::Entities::encode($showpath,'<>&"')).
+ ' '."\n";
+ }
+ unless ($ishome) {
+ my $fetch = "$fullpath/$title";
+ $fetch =~ s/^\Q$prefix$dir\E//;
+ $prompttofetch{$fetch} = 1;
+ }
}
- } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {
- $warning .= &mt('[_1] is a dependency of [_2], which was discarded.',
- $path,$env{'form.archive_content_'.$referrer{$i}}).' ';
}
+ } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {
+ $warning .= &mt('[_1] is a dependency of [_2], which was discarded.',
+ &HTML::Entities::encode($path,'<>&"'),
+ &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')).
+ ' ';
}
} else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).' ';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path)).' ';
}
}
if (keys(%todelete)) {
@@ -10998,7 +12977,7 @@ sub cleanup_empty_dirs {
my $numitems = 0;
foreach my $item (@dircontents) {
if (-d "$path/$item") {
- &recurse_dirs("$path/$item");
+ &cleanup_empty_dirs("$path/$item");
if (-e "$path/$item") {
$numitems ++;
}
@@ -11017,7 +12996,7 @@ sub cleanup_empty_dirs {
=pod
-=item &get_folder_hierarchy()
+=item * &get_folder_hierarchy()
Provides hierarchy of names of folders/sub-folders containing the current
item,
@@ -11045,7 +13024,7 @@ sub get_folder_hierarchy {
my @pcs = split(/,/,$pcslist);
foreach my $pc (@pcs) {
if ($pc == 1) {
- push(@pathitems,&mt('Main Course Documents'));
+ push(@pathitems,&mt('Main Content'));
} else {
my $res = $navmap->getByMapPc($pc);
if (ref($res)) {
@@ -11058,15 +13037,15 @@ sub get_folder_hierarchy {
}
}
}
- }
- if ($showitem) {
- if ($mapres->{ID} eq '0.0') {
- push(@pathitems,&mt('Main Course Documents'));
- } else {
- my $maptitle = $mapres->compTitle();
- $maptitle =~ s/\W+/_/g;
- if ($maptitle ne '') {
- push(@pathitems,$maptitle);
+ if ($showitem) {
+ if ($mapres->{ID} eq '0.0') {
+ push(@pathitems,&mt('Main Content'));
+ } else {
+ my $maptitle = $mapres->compTitle();
+ $maptitle =~ s/\W+/_/g;
+ if ($maptitle ne '') {
+ push(@pathitems,$maptitle);
+ }
}
}
}
@@ -11127,6 +13106,9 @@ sub get_turnedin_filepath {
my $title = $res->compTitle();
$title =~ s/\W+/_/g;
if ($title ne '') {
+ if (($pc > 1) && (length($title) > 12)) {
+ $title = substr($title,0,12);
+ }
push(@pathitems,$title);
}
}
@@ -11135,6 +13117,9 @@ sub get_turnedin_filepath {
my $maptitle = $mapres->compTitle();
$maptitle =~ s/\W+/_/g;
if ($maptitle ne '') {
+ if (length($maptitle) > 12) {
+ $maptitle = substr($maptitle,0,12);
+ }
push(@pathitems,$maptitle);
}
unless ($env{'request.state'} eq 'construct') {
@@ -11175,6 +13160,9 @@ sub get_turnedin_filepath {
$restitle = time;
}
}
+ if (length($restitle) > 12) {
+ $restitle = substr($restitle,0,12);
+ }
push(@pathitems,$restitle);
$path .= join('/',@pathitems);
}
@@ -11204,12 +13192,14 @@ sub upfile_store {
$env{'form.upfile'}=~s/\n+/\n/gs;
$env{'form.upfile'}=~s/\n+$//gs;
- my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
- '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
+ my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
+ '_enroll_'.$env{'request.course.id'}.'_'.
+ time.'_'.$$);
+ return if ($datatoken eq '');
{
my $datafile = $r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp';
- if ( open(my $fh,">$datafile") ) {
+ if ( open(my $fh,'>',$datafile) ) {
print $fh $env{'form.upfile'};
close($fh);
}
@@ -11219,21 +13209,22 @@ sub upfile_store {
=pod
-=item * &load_tmp_file($r)
+=item * &load_tmp_file($r,$datatoken)
Load uploaded file from tmp, $r should be the HTTP Request object,
-needs $env{'form.datatoken'},
+$datatoken is the name to assign to the temporary file.
sets $env{'form.upfile'} to the contents of the file
=cut
sub load_tmp_file {
- my $r=shift;
+ my ($r,$datatoken) = @_;
+ return if ($datatoken eq '');
my @studentdata=();
{
my $studentfile = $r->dir_config('lonDaemons').
- '/tmp/'.$env{'form.datatoken'}.'.tmp';
- if ( open(my $fh,"<$studentfile") ) {
+ '/tmp/'.$datatoken.'.tmp';
+ if ( open(my $fh,'<',$studentfile) ) {
@studentdata=<$fh>;
close($fh);
}
@@ -11241,6 +13232,14 @@ sub load_tmp_file {
$env{'form.upfile'}=join('',@studentdata);
}
+sub valid_datatoken {
+ my ($datatoken) = @_;
+ if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) {
+ return $datatoken;
+ }
+ return;
+}
+
=pod
=item * &upfile_record_sep()
@@ -11681,7 +13680,7 @@ sub DrawBarGraph {
@Labels = @$labels;
} else {
for (my $i=0;$i<@{$Values[0]};$i++) {
- push (@Labels,$i+1);
+ push(@Labels,$i+1);
}
}
#
@@ -12112,18 +14111,29 @@ sub restore_settings {
=item * &build_recipient_list()
-Build recipient lists for five types of e-mail:
+Build recipient lists for following types of e-mail:
(a) Error Reports, (b) Package Updates, (c) lonstatus warnings/errors
-(d) Help requests, (e) Course requests needing approval, generated by
-lonerrorhandler.pm, CHECKRPMS, loncron, lonsupportreq.pm and
-loncoursequeueadmin.pm respectively.
+(d) Help requests, (e) Course requests needing approval, (f) loncapa
+module change checking, student/employee ID conflict checks, as
+generated by lonerrorhandler.pm, CHECKRPMS, loncron,
+lonsupportreq.pm, loncoursequeueadmin.pm, searchcat.pl respectively.
Inputs:
-defmail (scalar - email address of default recipient),
-mailing type (scalar - errormail, packagesmail, or helpdeskmail),
+defmail (scalar - email address of default recipient),
+mailing type (scalar: errormail, packagesmail, helpdeskmail,
+requestsmail, updatesmail, or idconflictsmail).
+
defdom (domain for which to retrieve configuration settings),
-origmail (scalar - email address of recipient from loncapa.conf,
-i.e., predates configuration by DC via domainprefs.pm
+
+origmail (scalar - email address of recipient from loncapa.conf,
+i.e., predates configuration by DC via domainprefs.pm
+
+$requname username of requester (if mailing type is helpdeskmail)
+
+$requdom domain of requester (if mailing type is helpdeskmail)
+
+$reqemail e-mail address of requester (if mailing type is helpdeskmail)
+
Returns: comma separated list of addresses to which to send e-mail.
@@ -12134,11 +14144,11 @@ Returns: comma separated list of address
############################################################
############################################################
sub build_recipient_list {
- my ($defmail,$mailing,$defdom,$origmail) = @_;
+ my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;
my @recipients;
- my $otheremails;
+ my ($otheremails,$lastresort,$allbcc,$addtext);
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
+ &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
if (ref($domconfig{'contacts'}) eq 'HASH') {
if (exists($domconfig{'contacts'}{$mailing})) {
if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
@@ -12150,14 +14160,184 @@ sub build_recipient_list {
push(@recipients,$addr);
}
}
- $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
+ }
+ $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
+ if ($mailing eq 'helpdeskmail') {
+ if ($domconfig{'contacts'}{$mailing}{'bcc'}) {
+ my @bccs = split(/,/,$domconfig{'contacts'}{$mailing}{'bcc'});
+ my @ok_bccs;
+ foreach my $bcc (@bccs) {
+ $bcc =~ s/^\s+//g;
+ $bcc =~ s/\s+$//g;
+ if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+ if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+ push(@ok_bccs,$bcc);
+ }
+ }
+ }
+ if (@ok_bccs > 0) {
+ $allbcc = join(', ',@ok_bccs);
+ }
+ }
+ $addtext = $domconfig{'contacts'}{$mailing}{'include'};
}
}
} elsif ($origmail ne '') {
- push(@recipients,$origmail);
+ $lastresort = $origmail;
+ }
+ if ($mailing eq 'helpdeskmail') {
+ if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') &&
+ (keys(%{$domconfig{'contacts'}{'overrides'}}))) {
+ my ($inststatus,$inststatus_checked);
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
+ ($env{'user.domain'} ne 'public')) {
+ $inststatus_checked = 1;
+ $inststatus = $env{'environment.inststatus'};
+ }
+ unless ($inststatus_checked) {
+ if (($requname ne '') && ($requdom ne '')) {
+ if (($requname =~ /^$match_username$/) &&
+ ($requdom =~ /^$match_domain$/) &&
+ (&Apache::lonnet::domain($requdom))) {
+ my $requhome = &Apache::lonnet::homeserver($requname,
+ $requdom);
+ unless ($requhome eq 'no_host') {
+ my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus');
+ $inststatus = $userenv{'inststatus'};
+ $inststatus_checked = 1;
+ }
+ }
+ }
+ }
+ unless ($inststatus_checked) {
+ if ($reqemail =~ /^[^\@]+\@[^\@]+$/) {
+ my %srch = (srchby => 'email',
+ srchdomain => $defdom,
+ srchterm => $reqemail,
+ srchtype => 'exact');
+ my %srch_results = &Apache::lonnet::usersearch(\%srch);
+ foreach my $uname (keys(%srch_results)) {
+ if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+ $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+ $inststatus_checked = 1;
+ last;
+ }
+ }
+ unless ($inststatus_checked) {
+ my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch);
+ if ($dirsrchres eq 'ok') {
+ foreach my $uname (keys(%srch_results)) {
+ if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+ $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+ $inststatus_checked = 1;
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ if ($inststatus ne '') {
+ foreach my $status (split(/\:/,$inststatus)) {
+ if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') {
+ my @contacts = ('adminemail','supportemail');
+ foreach my $item (@contacts) {
+ if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) {
+ my $addr = $domconfig{'contacts'}{'overrides'}{$status};
+ if (!grep(/^\Q$addr\E$/,@recipients)) {
+ push(@recipients,$addr);
+ }
+ }
+ }
+ $otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'};
+ if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) {
+ my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'});
+ my @ok_bccs;
+ foreach my $bcc (@bccs) {
+ $bcc =~ s/^\s+//g;
+ $bcc =~ s/\s+$//g;
+ if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+ if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+ push(@ok_bccs,$bcc);
+ }
+ }
+ }
+ if (@ok_bccs > 0) {
+ $allbcc = join(', ',@ok_bccs);
+ }
+ }
+ $addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'};
+ last;
+ }
+ }
+ }
+ }
}
} elsif ($origmail ne '') {
- push(@recipients,$origmail);
+ $lastresort = $origmail;
+ }
+
+ if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {
+ unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {
+ my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
+ my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};
+ my %what = (
+ perlvar => 1,
+ );
+ my $primary = &Apache::lonnet::domain($defdom,'primary');
+ if ($primary) {
+ my $gotaddr;
+ my ($result,$returnhash) =
+ &Apache::lonnet::get_remote_globals($primary,{ perlvar => 1 });
+ if (($result eq 'ok') && (ref($returnhash) eq 'HASH')) {
+ if ($returnhash->{'lonSupportEMail'} =~ /^[^\@]+\@[^\@]+$/) {
+ $lastresort = $returnhash->{'lonSupportEMail'};
+ $gotaddr = 1;
+ }
+ }
+ unless ($gotaddr) {
+ my $uintdom = &Apache::lonnet::internet_dom($primary);
+ my $intdom = &Apache::lonnet::internet_dom($lonhost);
+ unless ($uintdom eq $intdom) {
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['contacts'],$machinedom);
+ if (ref($domconfig{'contacts'}) eq 'HASH') {
+ if (ref($domconfig{'contacts'}{'otherdomsmail'}) eq 'HASH') {
+ my @contacts = ('adminemail','supportemail');
+ foreach my $item (@contacts) {
+ if ($domconfig{'contacts'}{'otherdomsmail'}{$item}) {
+ my $addr = $domconfig{'contacts'}{$item};
+ if (!grep(/^\Q$addr\E$/,@recipients)) {
+ push(@recipients,$addr);
+ }
+ }
+ }
+ if ($domconfig{'contacts'}{'otherdomsmail'}{'others'}) {
+ $otheremails = $domconfig{'contacts'}{'otherdomsmail'}{'others'};
+ }
+ if ($domconfig{'contacts'}{'otherdomsmail'}{'bcc'}) {
+ my @bccs = split(/,/,$domconfig{'contacts'}{'otherdomsmail'}{'bcc'});
+ my @ok_bccs;
+ foreach my $bcc (@bccs) {
+ $bcc =~ s/^\s+//g;
+ $bcc =~ s/\s+$//g;
+ if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+ if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+ push(@ok_bccs,$bcc);
+ }
+ }
+ }
+ if (@ok_bccs > 0) {
+ $allbcc = join(', ',@ok_bccs);
+ }
+ }
+ $addtext = $domconfig{'contacts'}{'otherdomsmail'}{'include'};
+ }
+ }
+ }
+ }
+ }
+ }
}
if (defined($defmail)) {
if ($defmail ne '') {
@@ -12177,8 +14357,21 @@ sub build_recipient_list {
}
}
}
- my $recipientlist = join(',',@recipients);
- return $recipientlist;
+ if ($mailing eq 'helpdeskmail') {
+ if ((!@recipients) && ($lastresort ne '')) {
+ push(@recipients,$lastresort);
+ }
+ } elsif ($lastresort ne '') {
+ if (!grep(/^\Q$lastresort\E$/,@recipients)) {
+ push(@recipients,$lastresort);
+ }
+ }
+ my $recipientlist = join(',',@recipients);
+ if (wantarray) {
+ return ($recipientlist,$allbcc,$addtext);
+ } else {
+ return $recipientlist;
+ }
}
############################################################
@@ -12317,7 +14510,7 @@ sub extract_categories {
=pod
-=item *&recurse_categories()
+=item * &recurse_categories()
Recursively used to generate breadcrumb trails for course categories.
@@ -12388,7 +14581,7 @@ sub recurse_categories {
=pod
-=item *&assign_categories_table()
+=item * &assign_categories_table()
Create a datatable for display of hierarchical categories in a domain,
with checkboxes to allow a course to be categorized.
@@ -12402,12 +14595,15 @@ currcat - scalar with an & separated lis
type - scalar contains course type (Course or Community).
+disabled - scalar (optional) contains disabled="disabled" if input elements are
+ to be readonly (e.g., Domain Helpdesk role viewing course settings).
+
Returns: $output (markup to be displayed)
=cut
sub assign_categories_table {
- my ($cathash,$currcat,$type) = @_;
+ my ($cathash,$currcat,$type,$disabled) = @_;
my $output;
if (ref($cathash) eq 'HASH') {
my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
@@ -12443,11 +14639,11 @@ sub assign_categories_table {
}
$table .= ''.
' '.$parent_title.' '.
+ $item.'"'.$checked.$disabled.' />'.$parent_title.''.
' ';
my $depth = 1;
push(@path,$parent);
- $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
+ $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories,$disabled);
pop(@path);
$table .= ' ';
$itemcount ++;
@@ -12465,7 +14661,7 @@ sub assign_categories_table {
=pod
-=item *&assign_category_rows()
+=item * &assign_category_rows()
Create a datatable row for display of nested categories in a domain,
with checkboxes to allow a course to be categorized,called recursively.
@@ -12486,12 +14682,15 @@ path - Array containing all categories b
currcategories - reference to array of current categories assigned to the course
+disabled - scalar (optional) contains disabled="disabled" if input elements are
+ to be readonly (e.g., Domain Helpdesk role viewing course settings).
+
Returns: $output (markup to be displayed).
=cut
sub assign_category_rows {
- my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;
+ my ($itemcount,$cats,$depth,$parent,$path,$currcategories,$disabled) = @_;
my ($text,$name,$item,$chgstr);
if (ref($cats) eq 'ARRAY') {
my $maxdepth = scalar(@{$cats});
@@ -12499,7 +14698,7 @@ sub assign_category_rows {
if (ref($cats->[$depth]{$parent}) eq 'ARRAY') {
my $numchildren = @{$cats->[$depth]{$parent}};
my $css_class = $itemcount%2?' class="LC_odd_row"':'';
- $text .= '';
+ $text .= '';
for (my $j=0; $j<$numchildren; $j++) {
$name = $cats->[$depth]{$parent}[$j];
$item = &escape($name).':'.&escape($parent).':'.$depth;
@@ -12514,12 +14713,12 @@ sub assign_category_rows {
}
$text .= ''.
' '.$name.' '.
+ $item.'"'.$checked.$disabled.' />'.$name.''.
' '.
'';
if (ref($path) eq 'ARRAY') {
push(@{$path},$name);
- $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);
+ $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories,$disabled);
pop(@{$path});
}
$text .= ' ';
@@ -12531,6 +14730,12 @@ sub assign_category_rows {
return $text;
}
+=pod
+
+=back
+
+=cut
+
############################################################
############################################################
@@ -12547,7 +14752,7 @@ sub commit_customrole {
}
sub commit_standardrole {
- my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
+ my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context,$credits) = @_;
my ($output,$logmsg,$linefeed);
if ($context eq 'auto') {
$linefeed = "\n";
@@ -12556,7 +14761,7 @@ sub commit_standardrole {
}
if ($three eq 'st') {
my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
- $one,$two,$sec,$context);
+ $one,$two,$sec,$context,$credits);
if (($result =~ /^error/) || ($result eq 'not_in_class') ||
($result eq 'unknown_course') || ($result eq 'refused')) {
$output = $logmsg.' '.&mt('Error: ').$result."\n";
@@ -12587,7 +14792,8 @@ sub commit_standardrole {
}
sub commit_studentrole {
- my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
+ my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context,
+ $credits) = @_;
my ($result,$linefeed,$oldsecurl,$newsecurl);
if ($context eq 'auto') {
$linefeed = "\n";
@@ -12634,7 +14840,11 @@ sub commit_studentrole {
}
}
if (($expire_role_result eq 'ok') || ($secchange == 0)) {
- $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
+ $modify_section_result =
+ &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,
+ undef,undef,undef,$sec,
+ $end,$start,'','',$cid,
+ '',$context,$credits);
if ($modify_section_result =~ /^ok/) {
if ($secchange == 1) {
if ($sec eq '') {
@@ -12665,7 +14875,7 @@ sub commit_studentrole {
$result = $modify_section_result;
} elsif ($secchange == 1) {
if ($oldsec eq '') {
- $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
+ $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_2] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
} else {
$$logmsg .= &mt('Error when attempting to expire existing role for [_1] in section [_2] in course [_3] -error: ',$uname,$oldsec,$cid).' '.$expire_role_result.$linefeed;
}
@@ -12691,6 +14901,26 @@ sub commit_studentrole {
return $result;
}
+sub show_role_extent {
+ my ($scope,$context,$role) = @_;
+ $scope =~ s{^/}{};
+ my @courseroles = &Apache::lonuserutils::roles_by_context('course',1);
+ push(@courseroles,'co');
+ my @authorroles = &Apache::lonuserutils::roles_by_context('author');
+ if (($context eq 'course') || (grep(/^\Q$role\E/,@courseroles))) {
+ $scope =~ s{/}{_};
+ return ''.$env{'course.'.$scope.'.description'}.' ';
+ } elsif (($context eq 'author') || (grep(/^\Q$role\E/,@authorroles))) {
+ my ($audom,$auname) = split(/\//,$scope);
+ return &mt('[_1] Author Space',''.
+ &Apache::loncommon::plainname($auname,$audom).' ');
+ } else {
+ $scope =~ s{/$}{};
+ return &mt('Domain: [_1]',''.
+ &Apache::lonnet::domain($scope,'description').' ');
+ }
+}
+
############################################################
############################################################
@@ -12719,37 +14949,95 @@ sub check_clone {
return ($can_clone, $clonemsg, $cloneid, $clonehome);
}
}
- if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
+ if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
(&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) {
$can_clone = 1;
} else {
- my %clonehash = &Apache::lonnet::get('environment',['cloners'],
+ my %clonehash = &Apache::lonnet::get('environment',['cloners','internal.coursecode'],
$args->{'clonedomain'},$args->{'clonecourse'});
- my @cloners = split(/,/,$clonehash{'cloners'});
- if (grep(/^\*$/,@cloners)) {
- $can_clone = 1;
- } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
- $can_clone = 1;
+ if ($clonehash{'cloners'} eq '') {
+ my %domdefs = &Apache::lonnet::get_domain_defaults($args->{'course_domain'});
+ if ($domdefs{'canclone'}) {
+ unless ($domdefs{'canclone'} eq 'none') {
+ if ($domdefs{'canclone'} eq 'domain') {
+ if ($args->{'ccdomain'} eq $args->{'clonedomain'}) {
+ $can_clone = 1;
+ }
+ } elsif (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) &&
+ ($args->{'clonedomain'} eq $args->{'course_domain'})) {
+ if (&Apache::lonnet::default_instcode_cloning($args->{'clonedomain'},$domdefs{'canclone'},
+ $clonehash{'internal.coursecode'},$args->{'crscode'})) {
+ $can_clone = 1;
+ }
+ }
+ }
+ }
} else {
+ my @cloners = split(/,/,$clonehash{'cloners'});
+ if (grep(/^\*$/,@cloners)) {
+ $can_clone = 1;
+ } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
+ $can_clone = 1;
+ } elsif (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners)) {
+ $can_clone = 1;
+ }
+ unless ($can_clone) {
+ if (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) &&
+ ($args->{'clonedomain'} eq $args->{'course_domain'})) {
+ my (%gotdomdefaults,%gotcodedefaults);
+ foreach my $cloner (@cloners) {
+ if (($cloner ne '*') && ($cloner !~ /^\*\:$match_domain$/) &&
+ ($cloner !~ /^$match_username\:$match_domain$/) && ($cloner ne '')) {
+ my (%codedefaults,@code_order);
+ if (ref($gotcodedefaults{$args->{'clonedomain'}}) eq 'HASH') {
+ if (ref($gotcodedefaults{$args->{'clonedomain'}}{'defaults'}) eq 'HASH') {
+ %codedefaults = %{$gotcodedefaults{$args->{'clonedomain'}}{'defaults'}};
+ }
+ if (ref($gotcodedefaults{$args->{'clonedomain'}}{'order'}) eq 'ARRAY') {
+ @code_order = @{$gotcodedefaults{$args->{'clonedomain'}}{'order'}};
+ }
+ } else {
+ &Apache::lonnet::auto_instcode_defaults($args->{'clonedomain'},
+ \%codedefaults,
+ \@code_order);
+ $gotcodedefaults{$args->{'clonedomain'}}{'defaults'} = \%codedefaults;
+ $gotcodedefaults{$args->{'clonedomain'}}{'order'} = \@code_order;
+ }
+ if (@code_order > 0) {
+ if (&Apache::lonnet::check_instcode_cloning(\%codedefaults,\@code_order,
+ $cloner,$clonehash{'internal.coursecode'},
+ $args->{'crscode'})) {
+ $can_clone = 1;
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ unless ($can_clone) {
my $ccrole = 'cc';
if ($args->{'crstype'} eq 'Community') {
$ccrole = 'co';
}
- my %roleshash =
- &Apache::lonnet::get_my_roles($args->{'ccuname'},
- $args->{'ccdomain'},
- 'userroles',['active'],[$ccrole],
- [$args->{'clonedomain'}]);
- if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
+ my %roleshash =
+ &Apache::lonnet::get_my_roles($args->{'ccuname'},
+ $args->{'ccdomain'},
+ 'userroles',['active'],[$ccrole],
+ [$args->{'clonedomain'}]);
+ if ($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) {
$can_clone = 1;
- } elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'},$args->{'ccuname'},$args->{'ccdomain'})) {
+ } elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'},
+ $args->{'ccuname'},$args->{'ccdomain'})) {
$can_clone = 1;
+ }
+ }
+ unless ($can_clone) {
+ if ($args->{'crstype'} eq 'Community') {
+ $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
} else {
- if ($args->{'crstype'} eq 'Community') {
- $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
- } else {
- $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
- }
+ $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
}
}
}
@@ -12758,7 +15046,8 @@ sub check_clone {
}
sub construct_course {
- my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category) = @_;
+ my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
+ $cnum,$category,$coderef) = @_;
my $outcome;
my $linefeed = ' '."\n";
if ($context eq 'auto') {
@@ -12854,8 +15143,13 @@ sub construct_course {
'pch.users.denied',
'plc.users.denied',
'hidefromcat',
- 'categories'],
+ 'checkforpriv',
+ 'categories',
+ 'internal.uniquecode'],
$$crsudom,$$crsunum);
+ if ($args->{'textbook'}) {
+ $cenv{'internal.textbook'} = $args->{'textbook'};
+ }
}
#
@@ -12883,6 +15177,9 @@ sub construct_course {
} else {
$cenv{'internal.courseowner'} = $args->{'curruser'};
}
+ if ($args->{'defaultcredits'}) {
+ $cenv{'internal.defaultcredits'} = $args->{'defaultcredits'};
+ }
my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
if ($args->{'crssections'}) {
$cenv{'internal.sectionnums'} = '';
@@ -12898,7 +15195,7 @@ sub construct_course {
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
$cenv{'internal.sectionnums'} .= $item.',';
unless ($addcheck eq 'ok') {
- push @badclasses, $class;
+ push(@badclasses,$class);
}
}
$cenv{'internal.sectionnums'} =~ s/,$//;
@@ -12907,6 +15204,11 @@ sub construct_course {
# do not hide course coordinator from staff listing,
# even if privileged
$cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
+# add course coordinator's domain to domains to check for privileged users
+# if different to course domain
+ if ($$crsudom ne $args->{'ccdomain'}) {
+ $cenv{'checkforpriv'} = $args->{'ccdomain'};
+ }
# add crosslistings
if ($args->{'crsxlist'}) {
$cenv{'internal.crosslistings'}='';
@@ -12921,7 +15223,7 @@ sub construct_course {
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
$cenv{'internal.crosslistings'} .= $item.',';
unless ($addcheck eq 'ok') {
- push @badclasses, $xl;
+ push(@badclasses,$xl);
}
}
$cenv{'internal.crosslistings'} =~ s/,$//;
@@ -12956,28 +15258,29 @@ sub construct_course {
}
if (@badclasses > 0) {
my %lt=&Apache::lonlocal::texthash(
- 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course. However, if automated course roster updates are enabled for this class, these particular sections/crosslistings will not contribute towards enrollment, because the user identified as the course owner for this LON-CAPA course',
- 'dnhr' => 'does not have rights to access enrollment in these classes',
- 'adby' => 'as determined by the policies of your institution on access to official classlists'
+ 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course.',
+ 'howi' => 'However, if automated course roster updates are enabled for this class, these particular sections/crosslistings are not guaranteed to contribute towards enrollment.',
+ 'itis' => 'It is possible that rights to access enrollment for these classes will be available through assignment of co-owners.',
);
- my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
- ' ('.$lt{'adby'}.')';
+ my $badclass_msg = $lt{'tclb'}.$linefeed.$lt{'howi'}.$linefeed.
+ &mt('That is because the user identified as the course owner ([_1]) does not have rights to access enrollment in these classes, as determined by the policies of your institution on access to official classlists',$cenv{'internal.courseowner'}).$linefeed.$lt{'itis'};
if ($context eq 'auto') {
$outcome .= $badclass_msg.$linefeed;
+ } else {
$outcome .= ''.$badclass_msg.$linefeed.'
'."\n";
- foreach my $item (@badclasses) {
- if ($context eq 'auto') {
- $outcome .= " - $item\n";
- } else {
- $outcome .= "$item \n";
- }
- }
+ }
+ foreach my $item (@badclasses) {
if ($context eq 'auto') {
- $outcome .= $linefeed;
+ $outcome .= " - $item\n";
} else {
- $outcome .= " \n";
+ $outcome .= "$item \n";
}
- }
+ }
+ if ($context eq 'auto') {
+ $outcome .= $linefeed;
+ } else {
+ $outcome .= " \n";
+ }
}
if ($args->{'no_end_date'}) {
$args->{'endaccess'} = 0;
@@ -13009,6 +15312,9 @@ sub construct_course {
if ($args->{'setcontent'}) {
$cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
}
+ if ($args->{'setcomment'}) {
+ $cenv{'comment.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
+ }
}
if ($args->{'reshome'}) {
$cenv{'reshome'}=$args->{'reshome'}.'/';
@@ -13031,6 +15337,25 @@ sub construct_course {
}
}
+#
+# generate and store uniquecode (available to course requester), if course should have one.
+#
+ if ($args->{'uniquecode'}) {
+ my ($code,$error) = &make_unique_code($$crsudom,$$crsunum);
+ if ($code) {
+ $cenv{'internal.uniquecode'} = $code;
+ my %crsinfo =
+ &Apache::lonnet::courseiddump($$crsudom,'.',1,'.','.',$$crsunum,undef,undef,'.');
+ if (ref($crsinfo{$$crsudom.'_'.$$crsunum}) eq 'HASH') {
+ $crsinfo{$$crsudom.'_'.$$crsunum}{'uniquecode'} = $code;
+ my $putres = &Apache::lonnet::courseidput($$crsudom,\%crsinfo,$crsuhome,'notime');
+ }
+ if (ref($coderef)) {
+ $$coderef = $code;
+ }
+ }
+ }
+
if ($args->{'disresdis'}) {
$cenv{'pch.roles.denied'}='st';
}
@@ -13099,6 +15424,60 @@ sub construct_course {
return (1,$outcome);
}
+sub make_unique_code {
+ my ($cdom,$cnum) = @_;
+ # get lock on uniquecodes db
+ my $lockhash = {
+ $cnum."\0".'uniquecodes' => $env{'user.name'}.
+ ':'.$env{'user.domain'},
+ };
+ my $tries = 0;
+ my $gotlock = &Apache::lonnet::newput_dom('uniquecodes',$lockhash,$cdom);
+ my ($code,$error);
+
+ while (($gotlock ne 'ok') && ($tries<3)) {
+ $tries ++;
+ sleep 1;
+ $gotlock = &Apache::lonnet::newput_dom('uniquecodes',$lockhash,$cdom);
+ }
+ if ($gotlock eq 'ok') {
+ my %currcodes = &Apache::lonnet::dump_dom('uniquecodes',$cdom);
+ my $gotcode;
+ my $attempts = 0;
+ while ((!$gotcode) && ($attempts < 100)) {
+ $code = &generate_code();
+ if (!exists($currcodes{$code})) {
+ $gotcode = 1;
+ unless (&Apache::lonnet::newput_dom('uniquecodes',{ $code => $cnum },$cdom) eq 'ok') {
+ $error = 'nostore';
+ }
+ }
+ $attempts ++;
+ }
+ my @del_lock = ($cnum."\0".'uniquecodes');
+ my $dellockoutcome = &Apache::lonnet::del_dom('uniquecodes',\@del_lock,$cdom);
+ } else {
+ $error = 'nolock';
+ }
+ return ($code,$error);
+}
+
+sub generate_code {
+ my $code;
+ my @letts = qw(B C D G H J K M N P Q R S T V W X Z);
+ for (my $i=0; $i<6; $i++) {
+ my $lettnum = int (rand 2);
+ my $item = '';
+ if ($lettnum) {
+ $item = $letts[int( rand(18) )];
+ } else {
+ $item = 1+int( rand(8) );
+ }
+ $code .= $item;
+ }
+ return $code;
+}
+
############################################################
############################################################
@@ -13126,11 +15505,12 @@ sub group_term {
}
sub course_types {
- my @types = ('official','unofficial','community');
+ my @types = ('official','unofficial','community','textbook');
my %typename = (
official => 'Official course',
unofficial => 'Unofficial course',
community => 'Community',
+ textbook => 'Textbook course',
);
return (\@types,\%typename);
}
@@ -13191,7 +15571,7 @@ sub escape_url {
my ($url) = @_;
my @urlslices = split(/\//, $url,-1);
my $lastitem = &escape(pop(@urlslices));
- return join('/',@urlslices).'/'.$lastitem;
+ return &HTML::Entities::encode(join('/',@urlslices),"'").'/'.$lastitem;
}
sub compare_arrays {
@@ -13249,6 +15629,17 @@ sub init_user_environment {
}
}
closedir(DIR);
+# If there is a undeleted lockfile for the user's paste buffer remove it.
+ my $namespace = 'nohist_courseeditor';
+ my $lockingkey = 'paste'."\0".'locked_num';
+ my %lockhash = &Apache::lonnet::get($namespace,[$lockingkey],
+ $domain,$username);
+ if (exists($lockhash{$lockingkey})) {
+ my $delresult = &Apache::lonnet::del($namespace,[$lockingkey],$domain,$username);
+ unless ($delresult eq 'ok') {
+ &Apache::lonnet::logthis("Failed to delete paste buffer locking key in $namespace for ".$username.":".$domain." Result was: $delresult");
+ }
+ }
}
# Give them a new cookie
my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
@@ -13262,15 +15653,14 @@ sub init_user_environment {
}
# ------------------------------------ Check browser type and MathML capability
- my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
- $clientunicode,$clientos) = &decode_user_agent($r);
+ my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,$clientunicode,
+ $clientos,$clientmobile,$clientinfo,$clientosversion) = &decode_user_agent($r);
# ------------------------------------------------------------- Get environment
my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
my ($tmp) = keys(%userenv);
- if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
- } else {
+ if ($tmp =~ /^(con_lost|error|no_such_host)/i) {
undef(%userenv);
}
if (($userenv{'interface'}) && (!$form->{'interface'})) {
@@ -13294,6 +15684,9 @@ sub init_user_environment {
"browser.mathml" => $clientmathml,
"browser.unicode" => $clientunicode,
"browser.os" => $clientos,
+ "browser.mobile" => $clientmobile,
+ "browser.info" => $clientinfo,
+ "browser.osversion" => $clientosversion,
"server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
"request.course.fn" => '',
"request.course.uri" => '',
@@ -13313,23 +15706,51 @@ sub init_user_environment {
$env{'browser.interface'}=$form->{'interface'};
}
- my %is_adv = ( is_adv => $env{'user.adv'} );
- my %domdef;
- unless ($domain eq 'public') {
- %domdef = &Apache::lonnet::get_domain_defaults($domain);
+ if ($form->{'iptoken'}) {
+ my $lonhost = $r->dir_config('lonHostID');
+ $initial_env{"user.noloadbalance"} = $lonhost;
+ $env{'user.noloadbalance'} = $lonhost;
}
- foreach my $tool ('aboutme','blog','portfolio') {
- $userenv{'availabletools.'.$tool} =
- &Apache::lonnet::usertools_access($username,$domain,$tool,'reload',
- undef,\%userenv,\%domdef,\%is_adv);
+ if ($form->{'noloadbalance'}) {
+ my @hosts = &Apache::lonnet::current_machine_ids();
+ my $hosthere = $form->{'noloadbalance'};
+ if (grep(/^\Q$hosthere\E$/,@hosts)) {
+ $initial_env{"user.noloadbalance"} = $hosthere;
+ $env{'user.noloadbalance'} = $hosthere;
+ }
}
- foreach my $crstype ('official','unofficial','community') {
- $userenv{'canrequest.'.$crstype} =
- &Apache::lonnet::usertools_access($username,$domain,$crstype,
- 'reload','requestcourses',
+ unless ($domain eq 'public') {
+ my %is_adv = ( is_adv => $env{'user.adv'} );
+ my %domdef = &Apache::lonnet::get_domain_defaults($domain);
+
+ foreach my $tool ('aboutme','blog','webdav','portfolio') {
+ $userenv{'availabletools.'.$tool} =
+ &Apache::lonnet::usertools_access($username,$domain,$tool,'reload',
+ undef,\%userenv,\%domdef,\%is_adv);
+ }
+
+ foreach my $crstype ('official','unofficial','community','textbook') {
+ $userenv{'canrequest.'.$crstype} =
+ &Apache::lonnet::usertools_access($username,$domain,$crstype,
+ 'reload','requestcourses',
+ \%userenv,\%domdef,\%is_adv);
+ }
+
+ $userenv{'canrequest.author'} =
+ &Apache::lonnet::usertools_access($username,$domain,'requestauthor',
+ 'reload','requestauthor',
\%userenv,\%domdef,\%is_adv);
+ my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'],
+ $domain,$username);
+ my $reqstatus = $reqauthor{'author_status'};
+ if ($reqstatus eq 'approval' || $reqstatus eq 'approved') {
+ if (ref($reqauthor{'author'}) eq 'HASH') {
+ $userenv{'requestauthorqueued'} = $reqstatus.':'.
+ $reqauthor{'author'}{'timestamp'};
+ }
+ }
}
$env{'user.environment'} = "$lonids/$cookie.id";
@@ -13380,7 +15801,9 @@ sub get_symb {
my $symb=($env{'form.symb'} ne '' ? $env{'form.symb'} : (&Apache::lonnet::symbread($url)));
if ($symb eq '') {
if (!$silent) {
- $request->print("Unable to handle ambiguous references:$url:.");
+ if (ref($request)) {
+ $request->print("Unable to handle ambiguous references:$url:.");
+ }
return ();
}
}
@@ -13414,42 +15837,1350 @@ sub clean_symb {
return ($symb,$enc);
}
-sub build_release_hashes {
- my ($checkparms,$checkresponsetypes,$checkcrstypes,$anonsurvey,$randomizetry) = @_;
- return unless((ref($checkparms) eq 'HASH') && (ref($checkresponsetypes) eq 'HASH') &&
- (ref($checkcrstypes) eq 'HASH') && (ref($anonsurvey) eq 'HASH') &&
- (ref($randomizetry) eq 'HASH'));
- foreach my $key (keys(%Apache::lonnet::needsrelease)) {
- my ($item,$name,$value) = split(/:/,$key);
- if ($item eq 'parameter') {
- if (ref($checkparms->{$name}) eq 'ARRAY') {
- unless(grep(/^\Q$name\E$/,@{$checkparms->{$name}})) {
- push(@{$checkparms->{$name}},$value);
- }
+############################################################
+############################################################
+
+=pod
+
+=head1 Routines for building display used to search for courses
+
+
+=over 4
+
+=item * &build_filters()
+
+Create markup for a table used to set filters to use when selecting
+courses in a domain. Used by lonpickcourse.pm, lonmodifycourse.pm
+and quotacheck.pl
+
+
+Inputs:
+
+filterlist - anonymous array of fields to include as potential filters
+
+crstype - course type
+
+roleelement - fifth arg in selectcourse_link() populates fifth arg in javascript: opencrsbrowser() function, used
+ to pop-open a course selector (will contain "extra element").
+
+multelement - if multiple course selections will be allowed, this will be a hidden form element: name: multiple; value: 1
+
+filter - anonymous hash of criteria and their values
+
+action - form action
+
+numfiltersref - ref to scalar (count of number of elements in institutional codes -- e.g., 4 for year, semester, department, and number)
+
+caller - caller context (e.g., set to 'modifycourse' when routine is called from lonmodifycourse.pm)
+
+cloneruname - username of owner of new course who wants to clone
+
+clonerudom - domain of owner of new course who wants to clone
+
+typeelem - text to use for left column in row containing course type (i.e., Course, Community or Course/Community)
+
+codetitlesref - reference to array of titles of components in institutional codes (official courses)
+
+codedom - domain
+
+formname - value of form element named "form".
+
+fixeddom - domain, if fixed.
+
+prevphase - value to assign to form element named "phase" when going back to the previous screen
+
+cnameelement - name of form element in form on opener page which will receive title of selected course
+
+cnumelement - name of form element in form on opener page which will receive courseID of selected course
+
+cdomelement - name of form element in form on opener page which will receive domain of selected course
+
+setroles - includes access constraint identifier when setting a roles-based condition for acces to a portfolio file
+
+clonetext - hidden form elements containing list of courses cloneable by intended course owner when DC creates a course
+
+clonewarning - warning message about missing information for intended course owner when DC creates a course
+
+
+Returns: $output - HTML for display of search criteria, and hidden form elements.
+
+
+Side Effects: None
+
+=cut
+
+# ---------------------------------------------- search for courses based on last activity etc.
+
+sub build_filters {
+ my ($filterlist,$crstype,$roleelement,$multelement,$filter,$action,
+ $numtitlesref,$caller,$cloneruname,$clonerudom,$typeelement,
+ $codetitlesref,$codedom,$formname,$fixeddom,$prevphase,
+ $cnameelement,$cnumelement,$cdomelement,$setroles,
+ $clonetext,$clonewarning) = @_;
+ my ($list,$jscript);
+ my $onchange = 'javascript:updateFilters(this)';
+ my ($domainselectform,$sincefilterform,$createdfilterform,
+ $ownerdomselectform,$persondomselectform,$instcodeform,
+ $typeselectform,$instcodetitle);
+ if ($formname eq '') {
+ $formname = $caller;
+ }
+ foreach my $item (@{$filterlist}) {
+ unless (($item eq 'descriptfilter') || ($item eq 'instcodefilter') ||
+ ($item eq 'sincefilter') || ($item eq 'createdfilter')) {
+ if ($item eq 'domainfilter') {
+ $filter->{$item} = &LONCAPA::clean_domain($filter->{$item});
+ } elsif ($item eq 'coursefilter') {
+ $filter->{$item} = &LONCAPA::clean_courseid($filter->{$item});
+ } elsif ($item eq 'ownerfilter') {
+ $filter->{$item} = &LONCAPA::clean_username($filter->{$item});
+ } elsif ($item eq 'ownerdomfilter') {
+ $filter->{'ownerdomfilter'} =
+ &LONCAPA::clean_domain($filter->{$item});
+ $ownerdomselectform = &select_dom_form($filter->{'ownerdomfilter'},
+ 'ownerdomfilter',1);
+ } elsif ($item eq 'personfilter') {
+ $filter->{$item} = &LONCAPA::clean_username($filter->{$item});
+ } elsif ($item eq 'persondomfilter') {
+ $persondomselectform = &select_dom_form($filter->{'persondomfilter'},
+ 'persondomfilter',1);
} else {
- push(@{$checkparms->{$name}},$value);
+ $filter->{$item} =~ s/\W//g;
}
- } elsif ($item eq 'resourcetag') {
- if ($name eq 'responsetype') {
- $checkresponsetypes->{$value} = $Apache::lonnet::needsrelease{$key}
+ if (!$filter->{$item}) {
+ $filter->{$item} = '';
}
- } elsif ($item eq 'course') {
- if ($name eq 'crstype') {
- $checkcrstypes->{$value} = $Apache::lonnet::needsrelease{$key};
+ }
+ if ($item eq 'domainfilter') {
+ my $allow_blank = 1;
+ if ($formname eq 'portform') {
+ $allow_blank=0;
+ } elsif ($formname eq 'studentform') {
+ $allow_blank=0;
+ }
+ if ($fixeddom) {
+ $domainselectform = ' '.
+ &Apache::lonnet::domain($codedom,'description');
+ } else {
+ $domainselectform = &select_dom_form($filter->{$item},
+ 'domainfilter',
+ $allow_blank,'',$onchange);
}
+ } else {
+ $list->{$item} = &HTML::Entities::encode($filter->{$item},'<>&"');
}
}
- ($anonsurvey->{major},$anonsurvey->{minor}) = split(/\./,$Apache::lonnet::needsrelease{'parameter:type:anonsurvey'});
- ($randomizetry->{major},$randomizetry->{minor}) = split(/\./,$Apache::lonnet::needsrelease{'parameter:type:randomizetry'});
+
+ # last course activity filter and selection
+ $sincefilterform = &timebased_select_form('sincefilter',$filter);
+
+ # course created filter and selection
+ if (exists($filter->{'createdfilter'})) {
+ $createdfilterform = &timebased_select_form('createdfilter',$filter);
+ }
+
+ my %lt = &Apache::lonlocal::texthash(
+ 'cac' => "$crstype Activity",
+ 'ccr' => "$crstype Created",
+ 'cde' => "$crstype Title",
+ 'cdo' => "$crstype Domain",
+ 'ins' => 'Institutional Code',
+ 'inc' => 'Institutional Categorization',
+ 'cow' => "$crstype Owner/Co-owner",
+ 'cop' => "$crstype Personnel Includes",
+ 'cog' => 'Type',
+ );
+
+ if (($formname eq 'ccrs') || ($formname eq 'requestcrs')) {
+ my $typeval = 'Course';
+ if ($crstype eq 'Community') {
+ $typeval = 'Community';
+ }
+ $typeselectform = ' ';
+ } else {
+ $typeselectform = '".&mt($posstype)."\n";
+ }
+ $typeselectform.=" ";
+ }
+
+ my ($cloneableonlyform,$cloneabletitle);
+ if (exists($filter->{'cloneableonly'})) {
+ my $cloneableon = '';
+ my $cloneableoff = ' checked="checked"';
+ if ($filter->{'cloneableonly'}) {
+ $cloneableon = $cloneableoff;
+ $cloneableoff = '';
+ }
+ $cloneableonlyform = ' '.&mt('Required').' '.(' 'x3).' '.&mt('No restriction').' ';
+ if ($formname eq 'ccrs') {
+ $cloneabletitle = &mt('Cloneable for [_1]',$cloneruname.':'.$clonerudom);
+ } else {
+ $cloneabletitle = &mt('Cloneable by you');
+ }
+ }
+ my $officialjs;
+ if ($crstype eq 'Course') {
+ if (exists($filter->{'instcodefilter'})) {
+# if (($fixeddom) || ($formname eq 'requestcrs') ||
+# ($formname eq 'modifycourse') || ($formname eq 'filterpicker')) {
+ if ($codedom) {
+ $officialjs = 1;
+ ($instcodeform,$jscript,$$numtitlesref) =
+ &Apache::courseclassifier::instcode_selectors($codedom,'filterpicker',
+ $officialjs,$codetitlesref);
+ if ($jscript) {
+ $jscript = ''."\n";
+ }
+ }
+ if ($instcodeform eq '') {
+ $instcodeform =
+ ' ';
+ $instcodetitle = $lt{'ins'};
+ } else {
+ $instcodetitle = $lt{'inc'};
+ }
+ if ($fixeddom) {
+ $instcodetitle .= ' ('.$codedom.')';
+ }
+ }
+ }
+ my $output = qq|
+'."\n".' '."\n";
+ return $jscript.$clonewarning.$output;
+}
+
+=pod
+
+=item * &timebased_select_form()
+
+Create markup for a dropdown list used to select a time-based
+filter e.g., Course Activity, Course Created, when searching for courses
+or communities
+
+Inputs:
+
+item - name of form element (sincefilter or createdfilter)
+
+filter - anonymous hash of criteria and their values
+
+Returns: HTML for a select box contained a blank, then six time selections,
+ with value set in incoming form variables currently selected.
+
+Side Effects: None
+
+=cut
+
+sub timebased_select_form {
+ my ($item,$filter) = @_;
+ if (ref($filter) eq 'HASH') {
+ $filter->{$item} =~ s/[^\d-]//g;
+ if (!$filter->{$item}) { $filter->{$item}=-1; }
+ return &select_form(
+ $filter->{$item},
+ $item,
+ { '-1' => '',
+ '86400' => &mt('today'),
+ '604800' => &mt('last week'),
+ '2592000' => &mt('last month'),
+ '7776000' => &mt('last three months'),
+ '15552000' => &mt('last six months'),
+ '31104000' => &mt('last year'),
+ 'select_form_order' =>
+ ['-1','86400','604800','2592000','7776000',
+ '15552000','31104000']});
+ }
+}
+
+=pod
+
+=item * &js_changer()
+
+Create script tag containing Javascript used to submit course search form
+when course type or domain is changed, and also to hide 'Searching ...' on
+page load completion for page showing search result.
+
+Inputs: None
+
+Returns: markup containing updateFilters() and hideSearching() javascript functions.
+
+Side Effects: None
+
+=cut
+
+sub js_changer {
+ return <
+//
+
+
+ENDJS
+}
+
+=pod
+
+=item * &search_courses()
+
+Process selected filters form course search form and pass to lonnet::courseiddump
+to retrieve a hash for which keys are courseIDs which match the selected filters.
+
+Inputs:
+
+dom - domain being searched
+
+type - course type ('Course' or 'Community' or '.' if any).
+
+filter - anonymous hash of criteria and their values
+
+numtitles - for institutional codes - number of categories
+
+cloneruname - optional username of new course owner
+
+clonerudom - optional domain of new course owner
+
+domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by,
+ (used when DC is using course creation form)
+
+codetitles - reference to array of titles of components in institutional codes (official courses).
+
+cc_clone - escaped comma separated list of courses for which course cloner has active CC role
+ (and so can clone automatically)
+
+reqcrsdom - domain of new course, where search_courses is used to identify potential courses to clone
+
+reqinstcode - institutional code of new course, where search_courses is used to identify potential
+ courses to clone
+
+Returns: %courses - hash of courses satisfying search criteria, keys = course IDs, values are corresponding colon-separated escaped description, institutional code, owner and type.
+
+
+Side Effects: None
+
+=cut
+
+
+sub search_courses {
+ my ($dom,$type,$filter,$numtitles,$cloneruname,$clonerudom,$domcloner,$codetitles,
+ $cc_clone,$reqcrsdom,$reqinstcode) = @_;
+ my (%courses,%showcourses,$cloner);
+ if (($filter->{'ownerfilter'} ne '') ||
+ ($filter->{'ownerdomfilter'} ne '')) {
+ $filter->{'combownerfilter'} = $filter->{'ownerfilter'}.':'.
+ $filter->{'ownerdomfilter'};
+ }
+ foreach my $item ('descriptfilter','coursefilter','combownerfilter') {
+ if (!$filter->{$item}) {
+ $filter->{$item}='.';
+ }
+ }
+ my $now = time;
+ my $timefilter =
+ ($filter->{'sincefilter'}==-1?1:$now-$filter->{'sincefilter'});
+ my ($createdbefore,$createdafter);
+ if (($filter->{'createdfilter'} ne '') && ($filter->{'createdfilter'} !=-1)) {
+ $createdbefore = $now;
+ $createdafter = $now-$filter->{'createdfilter'};
+ }
+ my ($instcodefilter,$regexpok);
+ if ($numtitles) {
+ if ($env{'form.official'} eq 'on') {
+ $instcodefilter =
+ &Apache::courseclassifier::instcode_search_str($dom,$numtitles,$codetitles);
+ $regexpok = 1;
+ } elsif ($env{'form.official'} eq 'off') {
+ $instcodefilter = &Apache::courseclassifier::instcode_search_str($dom,$numtitles,$codetitles);
+ unless ($instcodefilter eq '') {
+ $regexpok = -1;
+ }
+ }
+ } else {
+ $instcodefilter = $filter->{'instcodefilter'};
+ }
+ if ($instcodefilter eq '') { $instcodefilter = '.'; }
+ if ($type eq '') { $type = '.'; }
+
+ if (($clonerudom ne '') && ($cloneruname ne '')) {
+ $cloner = $cloneruname.':'.$clonerudom;
+ }
+ %courses = &Apache::lonnet::courseiddump($dom,
+ $filter->{'descriptfilter'},
+ $timefilter,
+ $instcodefilter,
+ $filter->{'combownerfilter'},
+ $filter->{'coursefilter'},
+ undef,undef,$type,$regexpok,undef,undef,
+ undef,undef,$cloner,$cc_clone,
+ $filter->{'cloneableonly'},
+ $createdbefore,$createdafter,undef,
+ $domcloner,undef,$reqcrsdom,$reqinstcode);
+ if (($filter->{'personfilter'} ne '') && ($filter->{'persondomfilter'} ne '')) {
+ my $ccrole;
+ if ($type eq 'Community') {
+ $ccrole = 'co';
+ } else {
+ $ccrole = 'cc';
+ }
+ my %rolehash = &Apache::lonnet::get_my_roles($filter->{'personfilter'},
+ $filter->{'persondomfilter'},
+ 'userroles',undef,
+ [$ccrole,'in','ad','ep','ta','cr'],
+ $dom);
+ foreach my $role (keys(%rolehash)) {
+ my ($cnum,$cdom,$courserole) = split(':',$role);
+ my $cid = $cdom.'_'.$cnum;
+ if (exists($courses{$cid})) {
+ if (ref($courses{$cid}) eq 'HASH') {
+ if (ref($courses{$cid}{roles}) eq 'ARRAY') {
+ if (!grep(/^\Q$courserole\E$/,@{$courses{$cid}{roles}})) {
+ push(@{$courses{$cid}{roles}},$courserole);
+ }
+ } else {
+ $courses{$cid}{roles} = [$courserole];
+ }
+ $showcourses{$cid} = $courses{$cid};
+ }
+ }
+ }
+ %courses = %showcourses;
+ }
+ return %courses;
+}
+
+=pod
+
+=back
+
+=head1 Routines for version requirements for current course.
+
+=over 4
+
+=item * &check_release_required()
+
+Compares required LON-CAPA version with version on server, and
+if required version is newer looks for a server with the required version.
+
+Looks first at servers in user's owen domain; if none suitable, looks at
+servers in course's domain are permitted to host sessions for user's domain.
+
+Inputs:
+
+$loncaparev - Version on current server (format: Major.Minor.Subrelease-datestamp)
+
+$courseid - Course ID of current course
+
+$rolecode - User's current role in course (for switchserver query string).
+
+$required - LON-CAPA version needed by course (format: Major.Minor).
+
+
+Returns:
+
+$switchserver - query string tp append to /adm/switchserver call (if
+ current server's LON-CAPA version is too old.
+
+$warning - Message is displayed if no suitable server could be found.
+
+=cut
+
+sub check_release_required {
+ my ($loncaparev,$courseid,$rolecode,$required) = @_;
+ my ($switchserver,$warning);
+ if ($required ne '') {
+ my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);
+ my ($major,$minor) = ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+ if ($reqdmajor ne '' && $reqdminor ne '') {
+ my $otherserver;
+ if (($major eq '' && $minor eq '') ||
+ (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {
+ my ($userdomserver) = &Apache::lonnet::choose_server($env{'user.domain'},undef,$required,1);
+ my $switchlcrev =
+ &Apache::lonnet::get_server_loncaparev($env{'user.domain'},
+ $userdomserver);
+ my ($swmajor,$swminor) = ($switchlcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+ if (($swmajor eq '' && $swminor eq '') || ($reqdmajor > $swmajor) ||
+ (($reqdmajor == $swmajor) && ($reqdminor > $swminor))) {
+ my $cdom = $env{'course.'.$courseid.'.domain'};
+ if ($cdom ne $env{'user.domain'}) {
+ my ($coursedomserver,$coursehostname) = &Apache::lonnet::choose_server($cdom,undef,$required,1);
+ my $serverhomeID = &Apache::lonnet::get_server_homeID($coursehostname);
+ my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
+ my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
+ my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'});
+ my $remoterev = &Apache::lonnet::get_server_loncaparev($serverhomedom,$coursedomserver);
+ my $canhost =
+ &Apache::lonnet::can_host_session($env{'user.domain'},
+ $coursedomserver,
+ $remoterev,
+ $udomdefaults{'remotesessions'},
+ $defdomdefaults{'hostedsessions'});
+
+ if ($canhost) {
+ $otherserver = $coursedomserver;
+ } else {
+ $warning = &mt('Requires LON-CAPA version [_1].',$env{'course.'.$courseid.'.internal.releaserequired'}).' '. &mt("No suitable server could be found amongst servers in either your own domain or in the course's domain.");
+ }
+ } else {
+ $warning = &mt('Requires LON-CAPA version [_1].',$env{'course.'.$courseid.'.internal.releaserequired'}).' '.&mt("No suitable server could be found amongst servers in your own domain (which is also the course's domain).");
+ }
+ } else {
+ $otherserver = $userdomserver;
+ }
+ }
+ if ($otherserver ne '') {
+ $switchserver = 'otherserver='.$otherserver.'&role='.$rolecode;
+ }
+ }
+ }
+ return ($switchserver,$warning);
+}
+
+=pod
+
+=item * &check_release_result()
+
+Inputs:
+
+$switchwarning - Warning message if no suitable server found to host session.
+
+$switchserver - query string to append to /adm/switchserver containing lonHostID
+ and current role.
+
+Returns: HTML to display with information about requirement to switch server.
+ Either displaying warning with link to Roles/Courses screen or
+ display link to switchserver.
+
+=cut
+
+sub check_release_result {
+ my ($switchwarning,$switchserver) = @_;
+ my $output = &start_page('Selected course unavailable on this server').
+ '';
+ if ($switchwarning) {
+ $output .= $switchwarning.'';
+ if (&show_course()) {
+ $output .= &mt('Display courses');
+ } else {
+ $output .= &mt('Display roles');
+ }
+ $output .= ' ';
+ } elsif ($switchserver) {
+ $output .= &mt('This course requires a newer version of LON-CAPA than is installed on this server.').
+ ' '.
+ ''.
+ &mt('Switch Server').
+ ' ';
+ }
+ $output .= '
'.&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) = 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,$navmapref) = @_;
+ return unless ($symb && ref($navmapref));
+ 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;
+ unless (ref($$navmapref)) {
+ $$navmapref = Apache::lonnavmaps::navmap->new();
+ }
+ if (ref($$navmapref)) {
+ $mapresobj = $$navmapref->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 = $$navmapref->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,$version) =
+ &get_captcha_config($context,$lonhost);
+ if ($captcha eq 'original') {
+ $output = &create_captcha();
+ unless ($output) {
+ $error = 'captcha';
+ }
+ } elsif ($captcha eq 'recaptcha') {
+ $output = &create_recaptcha($pubkey,$version);
+ unless ($output) {
+ $error = 'recaptcha';
+ }
+ }
+ return ($output,$error,$captcha,$version);
+}
+
+sub captcha_response {
+ my ($context,$lonhost) = @_;
+ my ($captcha_chk,$captcha_error);
+ my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost);
+ if ($captcha eq 'original') {
+ ($captcha_chk,$captcha_error) = &check_captcha();
+ } elsif ($captcha eq 'recaptcha') {
+ $captcha_chk = &check_recaptcha($privkey,$version);
+ } else {
+ $captcha_chk = 1;
+ }
+ return ($captcha_chk,$captcha_error);
+}
+
+sub get_captcha_config {
+ my ($context,$lonhost) = @_;
+ my ($captcha,$pubkey,$privkey,$version,$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';
+ $version = $hashtocheck->{'recaptchaversion'};
+ if ($version ne '2') {
+ $version = 1;
+ }
+ } 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';
+ $version = $domconfhash{$serverhomedom.'.login.recaptchaversion'};
+ if ($version ne '2') {
+ $version = 1;
+ }
+ } else {
+ $captcha = 'original';
+ }
+ } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {
+ $captcha = 'original';
+ }
+ }
+ return ($captcha,$pubkey,$privkey,$version);
+}
+
+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,$version) = @_;
+ if ($version >= 2) {
+ return '
';
+ } else {
+ 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,$version) = @_;
+ my $captcha_chk;
+ if ($version >= 2) {
+ my $ua = LWP::UserAgent->new;
+ $ua->timeout(10);
+ my %info = (
+ secret => $privkey,
+ response => $env{'form.g-recaptcha-response'},
+ remoteip => $ENV{'REMOTE_ADDR'},
+ );
+ my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);
+ if ($response->is_success) {
+ my $data = JSON::DWIW->from_json($response->decoded_content);
+ if (ref($data) eq 'HASH') {
+ if ($data->{'success'}) {
+ $captcha_chk = 1;
+ }
+ }
+ }
+ } else {
+ 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','id');
+ 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)',
+ id => 'Student/Employee ID',
+ );
+ 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;
+}
+
+sub make_short_symbs {
+ my ($cdom,$cnum,$navmap) = @_;
+ return unless (ref($navmap));
+ my ($numnew,@errors);
+ my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny');
+ if (@toshorten) {
+ my (%maps,%resources,%titles);
+ &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles,
+ 'shorturls',$cdom,$cnum);
+ my %tocreate;
+ if (keys(%resources)) {
+ foreach my $item (sort {$a <=> $b} (@toshorten)) {
+ my $symb = $resources{$item};
+ if ($symb) {
+ $tocreate{$cnum.'&'.$symb} = 1;
+ }
+ }
+ }
+ if (keys(%tocreate)) {
+ my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum);
+ my $su = Short::URL->new(no_vowels => 1);
+ my $init = '';
+ my (%newunique,%addcourse,%courseonly,%failed);
+ # get lock on tiny db
+ my $now = time;
+ my $lockhash = {
+ "lock\0$now" => $env{'user.name'}.
+ ':'.$env{'user.domain'},
+ };
+ my $tries = 0;
+ my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
+ my ($code,$error);
+ while (($gotlock ne 'ok') && ($tries<3)) {
+ $tries ++;
+ sleep 1;
+ $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
+ }
+ if ($gotlock eq 'ok') {
+ $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,
+ \%addcourse,\%courseonly,\%failed);
+ if (keys(%failed)) {
+ my $numfailed = scalar(keys(%failed));
+ push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed));
+ }
+ if (keys(%newunique)) {
+ my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom);
+ if ($putres eq 'ok') {
+ $numnew = scalar(keys(%newunique));
+ my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum);
+ unless ($newputres eq 'ok') {
+ push(@errors,&mt('error: could not store course look-up of short URLs'));
+ }
+ } else {
+ push(@errors,&mt('error: could not store unique six character URLs'));
+ }
+ }
+ }
+ }
+ }
+ return ($numnew,\@errors);
+}
+
+sub shorten_symbs {
+ my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_;
+ return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') &&
+ (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') &&
+ (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH'));
+ my (%possibles,%collisions);
+ foreach my $key (keys(%{$tocreate})) {
+ my $num = String::CRC32::crc32($key);
+ my $tiny = $su->encode($num,$init);
+ if ($tiny) {
+ $possibles{$tiny} = $key;
+ }
+ }
+ if (!$init) {
+ $init = 1;
+ } else {
+ $init ++;
+ }
+ if (keys(%possibles)) {
+ my @posstiny = keys(%possibles);
+ my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
+ my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname);
+ if (keys(%currtiny)) {
+ foreach my $key (keys(%currtiny)) {
+ next if ($currtiny{$key} eq '');
+ if ($currtiny{$key} eq $possibles{$key}) {
+ my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key});
+ unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
+ $courseonly->{$tsymb} = $key;
+ }
+ } else {
+ $collisions{$possibles{$key}} = 1;
+ }
+ delete($possibles{$key});
+ }
+ }
+ foreach my $key (keys(%possibles)) {
+ $newunique->{$key} = $possibles{$key};
+ my ($tcnum,$tsymb) = split(/\&/,$possibles{$key});
+ unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
+ $addcourse->{$tsymb} = $key;
+ }
+ }
+ }
+ if (keys(%collisions)) {
+ if ($init <5) {
+ if (!$init) {
+ $init = 1;
+ } else {
+ $init ++;
+ }
+ $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions,
+ $newunique,$addcourse,$courseonly,$failed);
+ } else {
+ foreach my $key (keys(%collisions)) {
+ $failed->{$key} = 1;
+ }
+ }
+ }
+ return $init;
+}
+
1;
__END__;