'.
- &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 = '&"'))..
- ''."\n";
+ $result .= ''.&mt('Folder: [_1] added to course',$docstitle).' '."\n";
}
}
} else {
@@ -13224,140 +11220,116 @@ sub process_extracted_files {
my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.
$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.
$title;
- if (($outer !~ /\D/) &&
- (($mapinner{$outer} eq 'default') || ($mapinner{$outer} !~ /\D/)) &&
- ($newidx !~ /\D/)) {
- 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") {
- 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;
- }
- }
+ 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;
}
- $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";
- }
+ }
+ $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";
}
- } else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
- &HTML::Entities::encode($path,'<>&"')).' ';
}
}
}
- }
- } 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];
+ } 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);
for (my $j=0; $j<@{$dirorder{$i}}; $j++) {
- if ($dirorder{$i}->[$j] eq $container) {
- $itemidx = $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 ($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);
+ 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;
}
}
- } 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);
+ } 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;
}
}
- } else {
- last;
- }
- }
- }
- 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;
+ 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;
+ }
}
}
}
+ } 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.',
- &HTML::Entities::encode($path)).' ';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).' ';
}
}
if (keys(%todelete)) {
@@ -13416,7 +11388,7 @@ sub cleanup_empty_dirs {
my $numitems = 0;
foreach my $item (@dircontents) {
if (-d "$path/$item") {
- &cleanup_empty_dirs("$path/$item");
+ &recurse_dirs("$path/$item");
if (-e "$path/$item") {
$numitems ++;
}
@@ -13435,7 +11407,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,
@@ -13463,7 +11435,7 @@ sub get_folder_hierarchy {
my @pcs = split(/,/,$pcslist);
foreach my $pc (@pcs) {
if ($pc == 1) {
- push(@pathitems,&mt('Main Content'));
+ push(@pathitems,&mt('Main Course Documents'));
} else {
my $res = $navmap->getByMapPc($pc);
if (ref($res)) {
@@ -13478,7 +11450,7 @@ sub get_folder_hierarchy {
}
if ($showitem) {
if ($mapres->{ID} eq '0.0') {
- push(@pathitems,&mt('Main Content'));
+ push(@pathitems,&mt('Main Course Documents'));
} else {
my $maptitle = $mapres->compTitle();
$maptitle =~ s/\W+/_/g;
@@ -13545,9 +11517,6 @@ 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);
}
}
@@ -13556,9 +11525,6 @@ 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') {
@@ -13599,9 +11565,6 @@ sub get_turnedin_filepath {
$restitle = time;
}
}
- if (length($restitle) > 12) {
- $restitle = substr($restitle,0,12);
- }
push(@pathitems,$restitle);
$path .= join('/',@pathitems);
}
@@ -13631,15 +11594,12 @@ sub upfile_store {
$env{'form.upfile'}=~s/\n+/\n/gs;
$env{'form.upfile'}=~s/\n+$//gs;
- my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
- '_enroll_'.$env{'request.course.id'}.'_'.
- time.'_'.$$);
- return if ($datatoken eq '');
-
+ my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
+ '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
{
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);
}
@@ -13649,22 +11609,21 @@ sub upfile_store {
=pod
-=item * &load_tmp_file($r,$datatoken)
+=item * &load_tmp_file($r)
Load uploaded file from tmp, $r should be the HTTP Request object,
-$datatoken is the name to assign to the temporary file.
+needs $env{'form.datatoken'},
sets $env{'form.upfile'} to the contents of the file
=cut
sub load_tmp_file {
- my ($r,$datatoken) = @_;
- return if ($datatoken eq '');
+ my $r=shift;
my @studentdata=();
{
my $studentfile = $r->dir_config('lonDaemons').
- '/tmp/'.$datatoken.'.tmp';
- if ( open(my $fh,'<',$studentfile) ) {
+ '/tmp/'.$env{'form.datatoken'}.'.tmp';
+ if ( open(my $fh,"<$studentfile") ) {
@studentdata=<$fh>;
close($fh);
}
@@ -13672,14 +11631,6 @@ 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()
@@ -14120,7 +12071,7 @@ sub DrawBarGraph {
@Labels = @$labels;
} else {
for (my $i=0;$i<@{$Values[0]};$i++) {
- push(@Labels,$i+1);
+ push (@Labels,$i+1);
}
}
#
@@ -14551,28 +12502,18 @@ sub restore_settings {
=item * &build_recipient_list()
-Build recipient lists for following types of e-mail:
+Build recipient lists for five types of e-mail:
(a) Error Reports, (b) Package Updates, (c) lonstatus warnings/errors
-(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.
+(d) Help requests, (e) Course requests needing approval, generated by
+lonerrorhandler.pm, CHECKRPMS, loncron, lonsupportreq.pm and
+loncoursequeueadmin.pm respectively.
Inputs:
-defmail (scalar - email address of default recipient),
-mailing type (scalar: errormail, packagesmail, helpdeskmail,
-requestsmail, updatesmail, or idconflictsmail).
-
+defmail (scalar - email address of default recipient),
+mailing type (scalar - errormail, packagesmail, or helpdeskmail),
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
-
-$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)
+origmail (scalar - email address of recipient from loncapa.conf,
+i.e., predates configuration by DC via domainprefs.pm
Returns: comma separated list of addresses to which to send e-mail.
@@ -14583,11 +12524,11 @@ Returns: comma separated list of address
############################################################
############################################################
sub build_recipient_list {
- my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;
+ my ($defmail,$mailing,$defdom,$origmail) = @_;
my @recipients;
- my ($otheremails,$lastresort,$allbcc,$addtext);
+ my $otheremails;
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') {
@@ -14599,183 +12540,14 @@ sub build_recipient_list {
push(@recipients,$addr);
}
}
- }
- $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'};
+ $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
}
}
} elsif ($origmail ne '') {
- $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;
- }
- }
- }
- }
+ push(@recipients,$origmail);
}
} elsif ($origmail ne '') {
- $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'};
- }
- }
- }
- }
- }
- }
+ push(@recipients,$origmail);
}
if (defined($defmail)) {
if ($defmail ne '') {
@@ -14795,21 +12567,8 @@ sub build_recipient_list {
}
}
}
- 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;
- }
+ my $recipientlist = join(',',@recipients);
+ return $recipientlist;
}
############################################################
@@ -14900,8 +12659,6 @@ jsarray (reference to array of categorie
subcats (reference to hash of arrays containing all subcategories within each
category, -recursive)
-maxd (reference to hash used to hold max depth for all top-level categories).
-
Returns: nothing
Side effects: populates trails and allitems hash references.
@@ -14909,7 +12666,7 @@ Side effects: populates trails and allit
=cut
sub extract_categories {
- my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_;
+ my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
if (ref($categories) eq 'HASH') {
&gather_categories($categories,$cats,$idx,$jsarray);
if (ref($cats->[0]) eq 'ARRAY') {
@@ -14935,15 +12692,12 @@ sub extract_categories {
if (ref($subcats) eq 'HASH') {
push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
}
- &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd);
+ &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
}
} else {
if (ref($subcats) eq 'HASH') {
$subcats->{$item} = [];
}
- if (ref($maxd) eq 'HASH') {
- $maxd->{$name} = 1;
- }
}
}
}
@@ -14953,7 +12707,7 @@ sub extract_categories {
=pod
-=item * &recurse_categories()
+=item *&recurse_categories()
Recursively used to generate breadcrumb trails for course categories.
@@ -14981,13 +12735,13 @@ Side effects: populates trails and allit
=cut
sub recurse_categories {
- my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_;
+ my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
my $shallower = $depth - 1;
if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
my $name = $cats->[$depth]{$category}[$k];
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
- my $trailstr = join(' » ',(@{$parents},$category));
+ my $trailstr = join(' -> ',(@{$parents},$category));
if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;
@@ -15008,28 +12762,23 @@ sub recurse_categories {
}
}
&recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
- $subcats,$maxd);
+ $subcats);
pop(@{$parents});
}
} else {
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
- my $trailstr = join(' » ',(@{$parents},$category));
+ my $trailstr = join(' -> ',(@{$parents},$category));
if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;
}
- if (ref($maxd) eq 'HASH') {
- if ($depth > $maxd->{$parents->[0]}) {
- $maxd->{$parents->[0]} = $depth;
- }
- }
}
return;
}
=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.
@@ -15043,19 +12792,16 @@ 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,$disabled) = @_;
+ my ($cathash,$currcat,$type) = @_;
my $output;
if (ref($cathash) eq 'HASH') {
- my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth);
- &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd);
+ my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
+ &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
$maxdepth = scalar(@cats);
if (@cats > 0) {
my $itemcount = 0;
@@ -15087,11 +12833,11 @@ sub assign_categories_table {
}
$table .= ''.
' '.$parent_title.' '.
+ $item.'"'.$checked.' />'.$parent_title.''.
' ';
my $depth = 1;
push(@path,$parent);
- $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories,$disabled);
+ $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
pop(@path);
$table .= ' ';
$itemcount ++;
@@ -15109,7 +12855,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.
@@ -15130,15 +12876,12 @@ 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,$disabled) = @_;
+ my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;
my ($text,$name,$item,$chgstr);
if (ref($cats) eq 'ARRAY') {
my $maxdepth = scalar(@{$cats});
@@ -15146,7 +12889,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;
@@ -15161,12 +12904,12 @@ sub assign_category_rows {
}
$text .= ''.
' '.$name.' '.
+ $item.'"'.$checked.' />'.$name.''.
' '.
'';
if (ref($path) eq 'ARRAY') {
push(@{$path},$name);
- $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories,$disabled);
+ $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);
pop(@{$path});
}
$text .= ' ';
@@ -15178,12 +12921,6 @@ sub assign_category_rows {
return $text;
}
-=pod
-
-=back
-
-=cut
-
############################################################
############################################################
@@ -15200,7 +12937,7 @@ sub commit_customrole {
}
sub commit_standardrole {
- my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context,$credits) = @_;
+ my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
my ($output,$logmsg,$linefeed);
if ($context eq 'auto') {
$linefeed = "\n";
@@ -15209,7 +12946,7 @@ sub commit_standardrole {
}
if ($three eq 'st') {
my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
- $one,$two,$sec,$context,$credits);
+ $one,$two,$sec,$context);
if (($result =~ /^error/) || ($result eq 'not_in_class') ||
($result eq 'unknown_course') || ($result eq 'refused')) {
$output = $logmsg.' '.&mt('Error: ').$result."\n";
@@ -15240,8 +12977,7 @@ sub commit_standardrole {
}
sub commit_studentrole {
- my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context,
- $credits) = @_;
+ my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
my ($result,$linefeed,$oldsecurl,$newsecurl);
if ($context eq 'auto') {
$linefeed = "\n";
@@ -15265,8 +13001,7 @@ sub commit_studentrole {
}
$oldsecurl = $uurl;
$expire_role_result =
- &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,
- '','','',$context);
+ &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
if ($env{'request.course.sec'} ne '') {
if ($expire_role_result eq 'refused') {
my @roles = ('st');
@@ -15289,11 +13024,7 @@ 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,$credits);
+ $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
if ($modify_section_result =~ /^ok/) {
if ($secchange == 1) {
if ($sec eq '') {
@@ -15324,7 +13055,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 [_2] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
+ $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -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;
}
@@ -15350,26 +13081,6 @@ 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').' ');
- }
-}
-
############################################################
############################################################
@@ -15398,95 +13109,37 @@ 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','internal.coursecode'],
+ my %clonehash = &Apache::lonnet::get('environment',['cloners'],
$args->{'clonedomain'},$args->{'clonecourse'});
- 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;
- }
- }
- }
- }
+ my @cloners = split(/,/,$clonehash{'cloners'});
+ if (grep(/^\*$/,@cloners)) {
+ $can_clone = 1;
+ } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
+ $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}) {
+ 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))) {
$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 {
- $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'});
+ 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'});
+ }
}
}
}
@@ -15495,8 +13148,7 @@ sub check_clone {
}
sub construct_course {
- my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
- $cnum,$category,$coderef) = @_;
+ my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category) = @_;
my $outcome;
my $linefeed = ' '."\n";
if ($context eq 'auto') {
@@ -15592,12 +13244,8 @@ sub construct_course {
'pch.users.denied',
'plc.users.denied',
'hidefromcat',
- 'checkforpriv',
'categories'],
$$crsudom,$$crsunum);
- if ($args->{'textbook'}) {
- $cenv{'internal.textbook'} = $args->{'textbook'};
- }
}
#
@@ -15625,11 +13273,7 @@ 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.
- my @oklcsecs = (); # Used to accumulate LON-CAPA sections for validated institutional sections.
if ($args->{'crssections'}) {
$cenv{'internal.sectionnums'} = '';
if ($args->{'crssections'} =~ m/,/) {
@@ -15643,12 +13287,8 @@ sub construct_course {
my $class = $args->{'crscode'}.$sec;
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
$cenv{'internal.sectionnums'} .= $item.',';
- if ($addcheck eq 'ok') {
- unless (grep(/^\Q$gp\E$/,@oklcsecs)) {
- push(@oklcsecs,$gp);
- }
- } else {
- push(@badclasses,$class);
+ unless ($addcheck eq 'ok') {
+ push @badclasses, $class;
}
}
$cenv{'internal.sectionnums'} =~ s/,$//;
@@ -15657,11 +13297,6 @@ 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'}='';
@@ -15675,12 +13310,8 @@ sub construct_course {
my ($xl,$gp) = split/:/,$item;
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
$cenv{'internal.crosslistings'} .= $item.',';
- if ($addcheck eq 'ok') {
- unless (grep(/^\Q$gp\E$/,@oklcsecs)) {
- push(@oklcsecs,$gp);
- }
- } else {
- push(@badclasses,$xl);
+ unless ($addcheck eq 'ok') {
+ push @badclasses, $xl;
}
}
$cenv{'internal.crosslistings'} =~ s/,$//;
@@ -15715,63 +13346,32 @@ 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.',
- '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.',
+ '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'
);
- 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'};
+ my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
+ ' ('.$lt{'adby'}.')';
if ($context eq 'auto') {
$outcome .= $badclass_msg.$linefeed;
- } else {
$outcome .= ''.$badclass_msg.$linefeed.'
'."\n";
- }
- foreach my $item (@badclasses) {
+ foreach my $item (@badclasses) {
+ if ($context eq 'auto') {
+ $outcome .= " - $item\n";
+ } else {
+ $outcome .= "$item \n";
+ }
+ }
if ($context eq 'auto') {
- $outcome .= " - $item\n";
+ $outcome .= $linefeed;
} else {
- $outcome .= "$item \n";
+ $outcome .= " \n";
}
- }
- if ($context eq 'auto') {
- $outcome .= $linefeed;
- } else {
- $outcome .= " \n";
- }
+ }
}
if ($args->{'no_end_date'}) {
$args->{'endaccess'} = 0;
}
-# If an official course with institutional sections is created by cloning
-# an existing course, section-specific hiding of course totals in student's
-# view of grades as copied from cloned course, will be checked for valid
-# sections.
- if (($can_clone && $cloneid) &&
- ($cenv{'internal.coursecode'} ne '') &&
- ($cenv{'grading'} eq 'standard') &&
- ($cenv{'hidetotals'} ne '') &&
- ($cenv{'hidetotals'} ne 'all')) {
- my @hidesecs;
- my $deletehidetotals;
- if (@oklcsecs) {
- foreach my $sec (split(/,/,$cenv{'hidetotals'})) {
- if (grep(/^\Q$sec$/,@oklcsecs)) {
- push(@hidesecs,$sec);
- }
- }
- if (@hidesecs) {
- $cenv{'hidetotals'} = join(',',@hidesecs);
- } else {
- $deletehidetotals = 1;
- }
- } else {
- $deletehidetotals = 1;
- }
- if ($deletehidetotals) {
- delete($cenv{'hidetotals'});
- &Apache::lonnet::del('environment',['hidetotals'],$$crsudom,$$crsunum);
- }
- }
$cenv{'internal.autostart'}=$args->{'enrollstart'};
$cenv{'internal.autoend'}=$args->{'enrollend'};
$cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
@@ -15799,9 +13399,6 @@ 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'}.'/';
@@ -15824,25 +13421,6 @@ 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';
}
@@ -15873,17 +13451,12 @@ sub construct_course {
# Open all assignments
#
if ($args->{'openall'}) {
- my $opendate = time;
- if ($args->{'openallfrom'} =~ /^\d+$/) {
- $opendate = $args->{'openallfrom'};
- }
my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
- my %storecontent = ($storeunder => $opendate,
+ my %storecontent = ($storeunder => time,
$storeunder.'.type' => 'date_start');
- $outcome .= &mt('All assignments open starting [_1]',
- &Apache::lonlocal::locallocaltime($opendate)).': '.
- &Apache::lonnet::cput
- ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
+
+ $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
+ ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
}
#
# Set first page
@@ -15916,60 +13489,6 @@ 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;
-}
-
############################################################
############################################################
@@ -15997,12 +13516,11 @@ sub group_term {
}
sub course_types {
- my @types = ('official','unofficial','community','textbook');
+ my @types = ('official','unofficial','community');
my %typename = (
official => 'Official course',
unofficial => 'Unofficial course',
community => 'Community',
- textbook => 'Textbook course',
);
return (\@types,\%typename);
}
@@ -16063,7 +13581,7 @@ sub escape_url {
my ($url) = @_;
my @urlslices = split(/\//, $url,-1);
my $lastitem = &escape(pop(@urlslices));
- return &HTML::Entities::encode(join('/',@urlslices),"'").'/'.$lastitem;
+ return join('/',@urlslices).'/'.$lastitem;
}
sub compare_arrays {
@@ -16082,24 +13600,6 @@ sub compare_arrays {
return @difference;
}
-sub lon_status_items {
- my %defaults = (
- E => 100,
- W => 4,
- N => 1,
- U => 5,
- threshold => 200,
- sysmail => 2500,
- );
- my %names = (
- E => 'Errors',
- W => 'Warnings',
- N => 'Notices',
- U => 'Unsent',
- );
- return (\%defaults,\%names);
-}
-
# -------------------------------------------------------- Initialize user login
sub init_user_environment {
my ($r, $username, $domain, $authhost, $form, $args) = @_;
@@ -16135,37 +13635,10 @@ sub init_user_environment {
opendir(DIR,$lonids);
while ($filename=readdir(DIR)) {
if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
- if (tie(my %oldenv,'GDBM_File',"$lonids/$filename",
- &GDBM_READER(),0640)) {
- my $linkedfile;
- if (exists($oldenv{'user.linkedenv'})) {
- $linkedfile = $oldenv{'user.linkedenv'};
- }
- untie(%oldenv);
- if (unlink("$lonids/$filename")) {
- if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
- if (-l "$lonids/$linkedfile.id") {
- unlink("$lonids/$linkedfile.id");
- }
- }
- }
- } else {
- unlink($lonids.'/'.$filename);
- }
+ unlink($lonids.'/'.$filename);
}
}
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'}
@@ -16179,8 +13652,8 @@ sub init_user_environment {
}
# ------------------------------------ Check browser type and MathML capability
- my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,$clientunicode,
- $clientos,$clientmobile,$clientinfo,$clientosversion) = &decode_user_agent($r);
+ my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
+ $clientunicode,$clientos) = &decode_user_agent($r);
# ------------------------------------------------------------- Get environment
@@ -16202,7 +13675,6 @@ sub init_user_environment {
# --------------------------------------------------------- Write first profile
{
- my $ip = &Apache::lonnet::get_requestor_ip();
my %initial_env =
("user.name" => $username,
"user.domain" => $domain,
@@ -16212,16 +13684,13 @@ 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" => '',
"request.course.sec" => '',
"request.role" => 'cm',
"request.role.adv" => $env{'user.adv'},
- "request.host" => $ip,);
+ "request.host" => $ENV{'REMOTE_ADDR'},);
if ($form->{'localpath'}) {
$initial_env{"browser.localpath"} = $form->{'localpath'};
@@ -16234,51 +13703,23 @@ sub init_user_environment {
$env{'browser.interface'}=$form->{'interface'};
}
- if ($form->{'iptoken'}) {
- my $lonhost = $r->dir_config('lonHostID');
- $initial_env{"user.noloadbalance"} = $lonhost;
- $env{'user.noloadbalance'} = $lonhost;
+ my %is_adv = ( is_adv => $env{'user.adv'} );
+ my %domdef;
+ unless ($domain eq 'public') {
+ %domdef = &Apache::lonnet::get_domain_defaults($domain);
}
- 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 $tool ('aboutme','blog','portfolio') {
+ $userenv{'availabletools.'.$tool} =
+ &Apache::lonnet::usertools_access($username,$domain,$tool,'reload',
+ undef,\%userenv,\%domdef,\%is_adv);
}
- 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',
+ foreach my $crstype ('official','unofficial','community') {
+ $userenv{'canrequest.'.$crstype} =
+ &Apache::lonnet::usertools_access($username,$domain,$crstype,
+ 'reload','requestcourses',
\%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";
@@ -16365,1412 +13806,42 @@ sub clean_symb {
return ($symb,$enc);
}
-############################################################
-############################################################
-
-=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 {
- $filter->{$item} =~ s/\W//g;
- }
- if (!$filter->{$item}) {
- $filter->{$item} = '';
- }
- }
- 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');
+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);
+ }
} else {
- $domainselectform = &select_dom_form($filter->{$item},
- 'domainfilter',
- $allow_blank,'',$onchange);
+ push(@{$checkparms->{$name}},$value);
}
- } else {
- $list->{$item} = &HTML::Entities::encode($filter->{$item},'<>&"');
- }
- }
-
- # 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'};
+ } elsif ($item eq 'resourcetag') {
+ if ($name eq 'responsetype') {
+ $checkresponsetypes->{$value} = $Apache::lonnet::needsrelease{$key}
}
- if ($fixeddom) {
- $instcodetitle .= ' ('.$codedom.')';
+ } elsif ($item eq 'course') {
+ if ($name eq 'crstype') {
+ $checkcrstypes->{$value} = $Apache::lonnet::needsrelease{$key};
}
}
}
- 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 <
-// {major},$anonsurvey->{minor}) = split(/\./,$Apache::lonnet::needsrelease{'parameter:type:anonsurvey'});
+ ($randomizetry->{major},$randomizetry->{minor}) = split(/\./,$Apache::lonnet::needsrelease{'parameter:type:randomizetry'});
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 {
- my @order = @LONCAPA::map::order;
- if (@order > 0) {
- my @resources = @LONCAPA::map::resources;
- my @resparms = @LONCAPA::map::resparms;
- foreach my $idx (@order) {
- my ($title,$src,$ext,$type,$status)=split(/\:/,$resources[$idx]);
- 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,$defdom) = @_;
- my ($output,$error);
- my ($captcha,$pubkey,$privkey,$version) =
- &get_captcha_config($context,$lonhost,$defdom);
- 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,$defdom) = @_;
- my ($captcha_chk,$captcha_error);
- my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom);
- 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,$dom_in_effect) = @_;
- 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';
- }
- } elsif ($context eq 'passwords') {
- if ($dom_in_effect) {
- my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect);
- if ($passwdconf{'captcha'} eq 'recaptcha') {
- if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') {
- $pubkey = $passwdconf{'recaptchakeys'}{'public'};
- $privkey = $passwdconf{'recaptchakeys'}{'private'};
- }
- if ($privkey && $pubkey) {
- $captcha = 'recaptcha';
- $version = $passwdconf{'recaptchaversion'};
- if ($version ne '2') {
- $version = 1;
- }
- } else {
- $captcha = 'original';
- }
- } elsif ($passwdconf{'captcha'} ne 'notused') {
- $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;
- }
- }
- if ($output eq '') {
- &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts.");
- }
- 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;
- my $ip = &Apache::lonnet::get_requestor_ip();
- if ($version >= 2) {
- my $ua = LWP::UserAgent->new;
- $ua->timeout(10);
- my %info = (
- secret => $privkey,
- response => $env{'form.g-recaptcha-response'},
- remoteip => $ip,
- );
- 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,
- $ip,
- $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) = @_;
- unless (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
- return ();
- }
- 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] ne 'no_such_host') && ($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 is_nonframeable {
- my ($url,$absolute,$hostname,$ip,$nocache) = @_;
- my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);
- return if (($remprotocol eq '') || ($remhost eq ''));
-
- $remprotocol = lc($remprotocol);
- $remhost = lc($remhost);
- my $remport = 80;
- if ($remprotocol eq 'https') {
- $remport = 443;
- }
- my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport);
- if ($cached) {
- unless ($nocache) {
- if ($result) {
- return 1;
- } else {
- return 0;
- }
- }
- }
- my $uselink;
- my $request = new HTTP::Request('HEAD',$url);
- my $ua = LWP::UserAgent->new;
- $ua->timeout(5);
- my $response=$ua->request($request);
- if ($response->is_success()) {
- my $secpolicy = lc($response->header('content-security-policy'));
- my $xframeop = lc($response->header('x-frame-options'));
- $secpolicy =~ s/^\s+|\s+$//g;
- $xframeop =~ s/^\s+|\s+$//g;
- if (($secpolicy ne '') || ($xframeop ne '')) {
- my $remotehost = $remprotocol.'://'.$remhost;
- my ($origin,$protocol,$port);
- if ($ENV{'SERVER_PORT'} =~/^\d+$/) {
- $port = $ENV{'SERVER_PORT'};
- } else {
- $port = 80;
- }
- if ($absolute eq '') {
- $protocol = 'http:';
- if ($port == 443) {
- $protocol = 'https:';
- }
- $origin = $protocol.'//'.lc($hostname);
- } else {
- $origin = lc($absolute);
- ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$});
- }
- if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) {
- my $framepolicy = $1;
- $framepolicy =~ s/^\s+|\s+$//g;
- my @policies = split(/\s+/,$framepolicy);
- if (@policies) {
- if (grep(/^\Q'none'\E$/,@policies)) {
- $uselink = 1;
- } else {
- $uselink = 1;
- if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) ||
- (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) ||
- (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) {
- undef($uselink);
- }
- if ($uselink) {
- if (grep(/^\Q'self'\E$/,@policies)) {
- if (($origin ne '') && ($remotehost eq $origin)) {
- undef($uselink);
- }
- }
- }
- if ($uselink) {
- my @possok;
- if ($ip ne '') {
- push(@possok,$ip);
- }
- my $hoststr = '';
- foreach my $part (reverse(split(/\./,$hostname))) {
- if ($hoststr eq '') {
- $hoststr = $part;
- } else {
- $hoststr = "$part.$hoststr";
- }
- if ($hoststr eq $hostname) {
- push(@possok,$hostname);
- } else {
- push(@possok,"*.$hoststr");
- }
- }
- if (@possok) {
- foreach my $poss (@possok) {
- last if (!$uselink);
- foreach my $policy (@policies) {
- if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) {
- undef($uselink);
- last;
- }
- }
- }
- }
- }
- }
- }
- } elsif ($xframeop ne '') {
- $uselink = 1;
- my @policies = split(/\s*,\s*/,$xframeop);
- if (@policies) {
- unless (grep(/^deny$/,@policies)) {
- if ($origin ne '') {
- if (grep(/^sameorigin$/,@policies)) {
- if ($remotehost eq $origin) {
- undef($uselink);
- }
- }
- if ($uselink) {
- foreach my $policy (@policies) {
- if ($policy =~ /^allow-from\s*(.+)$/) {
- my $allowfrom = $1;
- if (($allowfrom ne '') && ($allowfrom eq $origin)) {
- undef($uselink);
- last;
- }
- }
- }
- }
- }
- }
- }
- }
- }
- }
- if ($nocache) {
- if ($cached) {
- my $devalidate;
- if ($uselink && !$result) {
- $devalidate = 1;
- } elsif (!$uselink && $result) {
- $devalidate = 1;
- }
- if ($devalidate) {
- &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport);
- }
- }
- } else {
- if ($uselink) {
- $result = 1;
- } else {
- $result = 0;
- }
- &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600);
- }
- return $uselink;
-}
-
1;
__END__;