version 1.1037, 2009/10/28 19:09:21
|
version 1.1053, 2010/03/08 14:28:50
|
Line 99 use LONCAPA::Configuration;
|
Line 99 use LONCAPA::Configuration;
|
my $readit; |
my $readit; |
my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 10; # Or some such value. |
|
|
my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true |
|
|
|
require Exporter; |
require Exporter; |
|
|
our @ISA = qw (Exporter); |
our @ISA = qw (Exporter); |
Line 1353 sub get_domain_defaults {
|
Line 1351 sub get_domain_defaults {
|
my %domdefaults; |
my %domdefaults; |
my %domconfig = |
my %domconfig = |
&Apache::lonnet::get_dom('configuration',['defaults','quotas', |
&Apache::lonnet::get_dom('configuration',['defaults','quotas', |
'requestcourses','inststatus'],$domain); |
'requestcourses','inststatus', |
|
'coursedefaults'],$domain); |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
Line 1388 sub get_domain_defaults {
|
Line 1387 sub get_domain_defaults {
|
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
} |
} |
} |
} |
|
if (ref($domconfig{'coursedefaults'}) eq 'HASH') { |
|
foreach my $item ('canuse_pdfforms') { |
|
$domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; |
|
} |
|
} |
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
$cachetime); |
$cachetime); |
return %domdefaults; |
return %domdefaults; |
Line 1722 sub userenvironment {
|
Line 1726 sub userenvironment {
|
unless ($uhome eq 'no_host') { |
unless ($uhome eq 'no_host') { |
my @answer=split(/\&/, |
my @answer=split(/\&/, |
&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome)); |
&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome)); |
|
if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) { |
|
return %returnhash; |
|
} |
my $i; |
my $i; |
for ($i=0;$i<=$#what;$i++) { |
for ($i=0;$i<=$#what;$i++) { |
$returnhash{$what[$i]}=&unescape($answer[$i]); |
$returnhash{$what[$i]}=&unescape($answer[$i]); |
Line 2147 sub clean_filename {
|
Line 2154 sub clean_filename {
|
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
return $fname; |
return $fname; |
} |
} |
#This Function check if a Image max 400px width and height 500px. If not then scale the image down |
# This Function checks if an Image's dimensions exceed either $resizewidth (width) |
|
# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an |
|
# image with the same aspect ratio as the original, but with dimensions which do |
|
# not exceed $resizewidth and $resizeheight. |
|
|
sub resizeImage { |
sub resizeImage { |
my($img_url) = @_; |
my ($img_path,$resizewidth,$resizeheight) = @_; |
my $ima = Image::Magick->new; |
my $ima = Image::Magick->new; |
$ima->Read($img_url); |
my $resized; |
if($ima->Get('width') > 400) |
if (-e $img_path) { |
{ |
$ima->Read($img_path); |
my $factor = $ima->Get('width')/400; |
if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) { |
$ima->Scale( width=>400, height=>$ima->Get('height')/$factor ); |
my $width = $ima->Get('width'); |
} |
my $height = $ima->Get('height'); |
if($ima->Get('height') > 500) |
if ($width > $resizewidth) { |
{ |
my $factor = $width/$resizewidth; |
my $factor = $ima->Get('height')/500; |
my $newheight = $height/$factor; |
$ima->Scale( width=>$ima->Get('width')/$factor, height=>500); |
$ima->Scale(width=>$resizewidth,height=>$newheight); |
} |
$resized = 1; |
|
} |
$ima->Write($img_url); |
} |
} |
if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) { |
|
my $width = $ima->Get('width'); |
#Wrapper function for userphotoupload |
my $height = $ima->Get('height'); |
sub userphotoupload |
if ($height > $resizeheight) { |
{ |
my $factor = $height/$resizeheight; |
my($formname,$subdir) = @_; |
my $newwidth = $width/$factor; |
$upload_photo_form = 1; |
$ima->Scale(width=>$newwidth,height=>$resizeheight); |
return &userfileupload($formname,undef,$subdir); |
$resized = 1; |
|
} |
|
} |
|
if ($resized) { |
|
$ima->Write($img_path); |
|
} |
|
} |
|
return; |
} |
} |
|
|
# --------------- Take an uploaded file and put it into the userfiles directory |
# --------------- Take an uploaded file and put it into the userfiles directory |
Line 2187 sub userphotoupload
|
Line 2205 sub userphotoupload
|
# $dsetudom - domain for permanaent storage of uploaded file |
# $dsetudom - domain for permanaent storage of uploaded file |
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
# $thumbheight - height (pixels) of thumbnail to make for uploaded image |
# $thumbheight - height (pixels) of thumbnail to make for uploaded image |
|
# $resizewidth - width (pixels) to which to resize uploaded image |
|
# $resizeheight - height (pixels) to which to resize uploaded image |
# |
# |
# output: url of file in userspace, or error: <message> |
# output: url of file in userspace, or error: <message> |
# or /adm/notfound.html if failure to upload occurse |
# or /adm/notfound.html if failure to upload occurse |
|
|
|
|
sub userfileupload { |
sub userfileupload { |
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
$destudom,$thumbwidth,$thumbheight)=@_; |
$destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_; |
if (!defined($subdir)) { $subdir='unknown'; } |
if (!defined($subdir)) { $subdir='unknown'; } |
my $fname=$env{'form.'.$formname.'.filename'}; |
my $fname=$env{'form.'.$formname.'.filename'}; |
$fname=&clean_filename($fname); |
$fname=&clean_filename($fname); |
Line 2244 sub userfileupload {
|
Line 2263 sub userfileupload {
|
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
return &finishuserfileupload($docuname,$docudom, |
return &finishuserfileupload($docuname,$docudom, |
$formname,$fname,$parser,$allfiles, |
$formname,$fname,$parser,$allfiles, |
$codebase,$thumbwidth,$thumbheight); |
$codebase,$thumbwidth,$thumbheight, |
|
$resizewidth,$resizeheight); |
} else { |
} else { |
$fname=$env{'form.folder'}.'/'.$fname; |
$fname=$env{'form.folder'}.'/'.$fname; |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
Line 2256 sub userfileupload {
|
Line 2276 sub userfileupload {
|
my $docudom=$destudom; |
my $docudom=$destudom; |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
$parser,$allfiles,$codebase, |
$parser,$allfiles,$codebase, |
$thumbwidth,$thumbheight); |
$thumbwidth,$thumbheight, |
|
$resizewidth,$resizeheight); |
|
|
} else { |
} else { |
my $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
Line 2267 sub userfileupload {
|
Line 2288 sub userfileupload {
|
} |
} |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
$parser,$allfiles,$codebase, |
$parser,$allfiles,$codebase, |
$thumbwidth,$thumbheight); |
$thumbwidth,$thumbheight, |
|
$resizewidth,$resizeheight); |
} |
} |
} |
} |
|
|
sub finishuserfileupload { |
sub finishuserfileupload { |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
$thumbwidth,$thumbheight) = @_; |
$thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_; |
my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
|
|
Line 2305 sub finishuserfileupload {
|
Line 2327 sub finishuserfileupload {
|
return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
} |
} |
close(FH); |
close(FH); |
if($upload_photo_form==1) |
if ($resizewidth && $resizeheight) { |
{ |
my $mm = new File::MMagic; |
resizeImage($filepath.'/'.$file); |
my $mime_type = $mm->checktype_filename($filepath.'/'.$file); |
$upload_photo_form = 0; |
if ($mime_type =~ m{^image/}) { |
|
&resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight); |
|
} |
} |
} |
} |
} |
if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
Line 2729 sub userrolelog {
|
Line 2753 sub userrolelog {
|
if (($trole=~/^ca/) || ($trole=~/^aa/) || |
if (($trole=~/^ca/) || ($trole=~/^aa/) || |
($trole=~/^in/) || ($trole=~/^cc/) || |
($trole=~/^in/) || ($trole=~/^cc/) || |
($trole=~/^ep/) || ($trole=~/^cr/) || |
($trole=~/^ep/) || ($trole=~/^cr/) || |
($trole=~/^ta/)) { |
($trole=~/^ta/) || ($trole=~/^co/)) { |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
$userrolehash |
$userrolehash |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
Line 2738 sub userrolelog {
|
Line 2762 sub userrolelog {
|
if (($env{'request.role'} =~ /dc\./) && |
if (($env{'request.role'} =~ /dc\./) && |
(($trole=~/^au/) || ($trole=~/^in/) || |
(($trole=~/^au/) || ($trole=~/^in/) || |
($trole=~/^cc/) || ($trole=~/^ep/) || |
($trole=~/^cc/) || ($trole=~/^ep/) || |
($trole=~/^cr/) || ($trole=~/^ta/))) { |
($trole=~/^cr/) || ($trole=~/^ta/) || |
|
($trole=~/^co/))) { |
$userrolehash |
$userrolehash |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
=$tend.':'.$tstart; |
=$tend.':'.$tstart; |
Line 2759 sub courserolelog {
|
Line 2784 sub courserolelog {
|
if (($trole eq 'cc') || ($trole eq 'in') || |
if (($trole eq 'cc') || ($trole eq 'in') || |
($trole eq 'ep') || ($trole eq 'ad') || |
($trole eq 'ep') || ($trole eq 'ad') || |
($trole eq 'ta') || ($trole eq 'st') || |
($trole eq 'ta') || ($trole eq 'st') || |
($trole=~/^cr/) || ($trole eq 'gr')) { |
($trole=~/^cr/) || ($trole eq 'gr') || |
|
($trole eq 'co')) { |
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
my $cdom = $1; |
my $cdom = $1; |
my $cnum = $2; |
my $cnum = $2; |
Line 3907 sub custom_roleprivs {
|
Line 3933 sub custom_roleprivs {
|
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
if (defined($syspriv)) { |
if (defined($syspriv)) { |
|
if ($trest =~ /^$match_community$/) { |
|
$syspriv =~ s/bre\&S//; |
|
} |
$$allroles{'cm./'}.=':'.$syspriv; |
$$allroles{'cm./'}.=':'.$syspriv; |
$$allroles{$spec.'./'}.=':'.$syspriv; |
$$allroles{$spec.'./'}.=':'.$syspriv; |
} |
} |
Line 4024 sub role_status {
|
Line 4053 sub role_status {
|
); |
); |
my $spec=$$role.'.'.$$where; |
my $spec=$$role.'.'.$$where; |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
if ($$role eq 'gr') { |
|
my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, |
|
$env{'user.name'})=@_; |
|
my ($trole) = split('_',$role,1); |
|
(undef,my $group_privs) = split(/\//,$trole); |
|
$group_privs = &unescape($group_privs); |
|
} |
|
if ($$role =~ /^cr\//) { |
if ($$role =~ /^cr\//) { |
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); |
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); |
} elsif ($$role eq 'gr') { |
} elsif ($$role eq 'gr') { |
Line 4806 sub usertools_access {
|
Line 4828 sub usertools_access {
|
} |
} |
} |
} |
|
|
|
sub is_course_owner { |
|
my ($cdom,$cnum,$udom,$uname) = @_; |
|
if (($udom eq '') || ($uname eq '')) { |
|
$udom = $env{'user.domain'}; |
|
$uname = $env{'user.name'}; |
|
} |
|
unless (($udom eq '') || ($uname eq '')) { |
|
if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) { |
|
if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) { |
|
return 1; |
|
} else { |
|
my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum); |
|
if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) { |
|
return 1; |
|
} |
|
} |
|
} |
|
} |
|
return; |
|
} |
|
|
sub is_advanced_user { |
sub is_advanced_user { |
my ($udom,$uname) = @_; |
my ($udom,$uname) = @_; |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
Line 5044 sub allowed {
|
Line 5087 sub allowed {
|
my $statecond=0; |
my $statecond=0; |
my $courseprivid=''; |
my $courseprivid=''; |
|
|
|
my $ownaccess; |
|
# Community Coordinator or Assistant Co-author browsing resource space. |
|
if (($priv eq 'bro') && ($env{'user.author'})) { |
|
if ($uri eq '') { |
|
$ownaccess = 1; |
|
} else { |
|
if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { |
|
my $udom = $env{'user.domain'}; |
|
my $uname = $env{'user.name'}; |
|
if ($uri =~ m{^\Q$udom\E/?$}) { |
|
$ownaccess = 1; |
|
} elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) { |
|
unless ($uri =~ m{\.\./}) { |
|
$ownaccess = 1; |
|
} |
|
} elsif (($udom ne 'public') && ($uname ne 'public')) { |
|
my $now = time; |
|
if ($uri =~ m{^([^/]+)/?$}) { |
|
my $adom = $1; |
|
foreach my $key (keys(%env)) { |
|
if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { |
|
my ($start,$end) = split('.',$env{$key}); |
|
if (($now >= $start) && (!$end || $end < $now)) { |
|
$ownaccess = 1; |
|
last; |
|
} |
|
} |
|
} |
|
} elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) { |
|
my $adom = $1; |
|
my $aname = $2; |
|
foreach my $role ('ca','aa') { |
|
if ($env{"user.role.$role./$adom/$aname"}) { |
|
my ($start,$end) = |
|
split('.',$env{"user.role.$role./$adom/$aname"}); |
|
if (($now >= $start) && (!$end || $end < $now)) { |
|
$ownaccess = 1; |
|
last; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
# Course |
# Course |
|
|
if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { |
if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { |
$thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
|
$thisallowed.=$1; |
|
} |
} |
} |
|
|
# Domain |
# Domain |
|
|
if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
$thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
|
$thisallowed.=$1; |
|
} |
} |
} |
|
|
# Course: uri itself is a course |
# Course: uri itself is a course |
Line 5064 sub allowed {
|
Line 5158 sub allowed {
|
|
|
if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} |
if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} |
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
$thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
|
$thisallowed.=$1; |
|
} |
} |
} |
|
|
# URI is an uploaded document for this course, default permissions don't matter |
# URI is an uploaded document for this course, default permissions don't matter |
Line 6084 sub devalidate_getgroups_cache {
|
Line 6180 sub devalidate_getgroups_cache {
|
|
|
sub plaintext { |
sub plaintext { |
my ($short,$type,$cid,$forcedefault) = @_; |
my ($short,$type,$cid,$forcedefault) = @_; |
if ($short =~ /^cr/) { |
if ($short =~ m{^cr/}) { |
return (split('/',$short))[-1]; |
return (split('/',$short))[-1]; |
} |
} |
if (!defined($cid)) { |
if (!defined($cid)) { |
Line 6173 sub assignrole {
|
Line 6269 sub assignrole {
|
$refused = 1; |
$refused = 1; |
} |
} |
if ($refused) { |
if ($refused) { |
if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
|
if (!$selfenroll && $context eq 'course') { |
|
my %crsenv; |
|
if ($role eq 'cc' || $role eq 'co') { |
|
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
|
if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) { |
|
if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) { |
|
if ($crsenv{'internal.courseowner'} eq |
|
$env{'user.name'}.':'.$env{'user.domain'}) { |
|
$refused = ''; |
|
} |
|
} |
|
} elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { |
|
if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) { |
|
if ($crsenv{'internal.courseowner'} eq |
|
$env{'user.name'}.':'.$env{'user.domain'}) { |
|
$refused = ''; |
|
} |
|
} |
|
} |
|
} |
|
} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
$refused = ''; |
$refused = ''; |
} elsif ($context eq 'requestcourses') { |
} elsif ($context eq 'requestcourses') { |
my @possroles = ('st','ta','ep','in','cc'); |
my @possroles = ('st','ta','ep','in','cc','co'); |
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { |
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
my $wrongcc; |
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
if ($cnum =~ /^$match_community$/) { |
if ($crsenv{'internal.courseowner'} eq |
$wrongcc = 1 if ($role eq 'cc'); |
$env{'user.name'}.':'.$env{'user.domain'}) { |
} else { |
$refused = ''; |
$wrongcc = 1 if ($role eq 'co'); |
|
} |
|
unless ($wrongcc) { |
|
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
|
if ($crsenv{'internal.courseowner'} eq |
|
$env{'user.name'}.':'.$env{'user.domain'}) { |
|
$refused = ''; |
|
} |
} |
} |
} |
} |
} |
} |
Line 6233 sub assignrole {
|
Line 6357 sub assignrole {
|
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
$origstart,$selfenroll,$context); |
$origstart,$selfenroll,$context); |
} |
} |
|
if ($role eq 'cc') { |
|
&autoupdate_coowners($url,$end,$start,$uname,$udom); |
|
} |
} |
} |
return $answer; |
return $answer; |
} |
} |
|
|
|
sub autoupdate_coowners { |
|
my ($url,$end,$start,$uname,$udom) = @_; |
|
my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)}); |
|
if (($cdom ne '') && ($cnum ne '')) { |
|
my $now = time; |
|
my %domdesign = &Apache::loncommon::get_domainconf($cdom); |
|
if ($domdesign{$cdom.'.autoassign.co-owners'}) { |
|
my %coursehash = &coursedescription($cdom.'_'.$cnum); |
|
my $instcode = $coursehash{'internal.coursecode'}; |
|
if ($instcode ne '') { |
|
unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) { |
|
my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom); |
|
if ($result eq 'valid') { |
|
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners); |
|
if (($end == 0) || ($end > $now)) { |
|
if ($coursehash{'internal.co-owners'}) { |
|
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { |
|
push(@newcoowners,$coowner); |
|
} |
|
unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) { |
|
push(@newcoowners,$uname.':'.$udom); |
|
} |
|
@newcoowners = sort(@newcoowners); |
|
} else { |
|
push(@newcoowners,$uname.':'.$udom); |
|
} |
|
} else { |
|
if ($coursehash{'internal.co-owners'}) { |
|
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { |
|
unless ($coowner eq $uname.':'.$udom) { |
|
push(@newcoowners,$coowner); |
|
} |
|
} |
|
unless (@newcoowners > 0) { |
|
$delcoowners = 1; |
|
$coowners = ''; |
|
} |
|
} |
|
} |
|
if (@newcoowners || $delcoowners) { |
|
&store_coowners($cdom,$cnum,$coursehash{'home'}, |
|
$delcoowners,@newcoowners); |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
sub store_coowners { |
|
my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_; |
|
my $cid = $cdom.'_'.$cnum; |
|
my ($coowners,$delresult,$putresult); |
|
if (@newcoowners) { |
|
$coowners = join(',',@newcoowners); |
|
my %coownershash = ( |
|
'internal.co-owners' => $coowners, |
|
); |
|
$putresult = &put('environment',\%coownershash,$cdom,$cnum); |
|
if ($putresult eq 'ok') { |
|
if ($env{'course.'.$cid.'.num'} eq $cnum) { |
|
&appenv({'course.'.$cid.'.internal.co-owners' => $coowners}); |
|
} |
|
} |
|
} |
|
if ($delcoowners) { |
|
$delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum); |
|
if ($delresult eq 'ok') { |
|
if ($env{'course.'.$cid.'.internal.co-owners'}) { |
|
&Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners'); |
|
} |
|
} |
|
} |
|
if (($putresult eq 'ok') || ($delresult eq 'ok')) { |
|
my %crsinfo = |
|
&Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); |
|
if (ref($crsinfo{$cid}) eq 'HASH') { |
|
$crsinfo{$cid}{'co-owners'} = \@newcoowners; |
|
my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime'); |
|
} |
|
} |
|
} |
|
|
# -------------------------------------------------- Modify user authentication |
# -------------------------------------------------- Modify user authentication |
# Overrides without validation |
# Overrides without validation |
|
|
Line 6554 sub createcourse {
|
Line 6765 sub createcourse {
|
if (($chome eq '') || ($chome eq 'no_host')) { |
if (($chome eq '') || ($chome eq 'no_host')) { |
$uname = $cnum; |
$uname = $cnum; |
} else { |
} else { |
$uname = &generate_coursenum($udom); |
$uname = &generate_coursenum($udom,$crstype); |
} |
} |
} else { |
} else { |
$uname = &generate_coursenum($udom); |
$uname = &generate_coursenum($udom,$crstype); |
} |
} |
return $uname if ($uname =~ /^error/); |
return $uname if ($uname =~ /^error/); |
# -------------------------------------------------- Check supplied server name |
# -------------------------------------------------- Check supplied server name |
$course_server = $env{'user.homeserver'} if (! defined($course_server)); |
if (!defined($course_server)) { |
if (! &is_library($course_server)) { |
if (defined(&domain($udom,'primary'))) { |
return 'error:bad server name '.$course_server; |
$course_server = &domain($udom,'primary'); |
|
} else { |
|
$course_server = $env{'user.home'}; |
|
} |
|
} |
|
my %host_servers = |
|
&Apache::lonnet::get_servers($udom,'library'); |
|
unless ($host_servers{$course_server}) { |
|
return 'error: invalid home server for course: '.$course_server; |
} |
} |
# ------------------------------------------------------------- Make the course |
# ------------------------------------------------------------- Make the course |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
Line 6617 ENDINITMAP
|
Line 6836 ENDINITMAP
|
|
|
# ------------------------------------------------------------------- Create ID |
# ------------------------------------------------------------------- Create ID |
sub generate_coursenum { |
sub generate_coursenum { |
my ($udom) = @_; |
my ($udom,$crstype) = @_; |
my $domdesc = &domain($udom); |
my $domdesc = &domain($udom); |
return 'error: invalid domain' if ($domdesc eq ''); |
return 'error: invalid domain' if ($domdesc eq ''); |
my $uname=int(1+rand(9)). |
my $first; |
|
if ($crstype eq 'Community') { |
|
$first = '0'; |
|
} else { |
|
$first = int(1+rand(9)); |
|
} |
|
my $uname=$first. |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
# ----------------------------------------------- Make sure that does not exist |
# ----------------------------------------------- Make sure that does not exist |
my $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
$uname=int(1+rand(9)). |
if ($crstype eq 'Community') { |
|
$first = '0'; |
|
} else { |
|
$first = int(1+rand(9)); |
|
} |
|
$uname=$first. |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
Line 10211 createcourse($udom,$description,$url,$co
|
Line 10441 createcourse($udom,$description,$url,$co
|
|
|
=item * |
=item * |
|
|
generate_coursenum($udom) : get a unique (unused) course number in domain $udom |
generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community). |
|
|
=back |
=back |
|
|