|
version 1.500, 2004/05/11 06:49:58
|
version 1.532, 2004/08/25 16:03:17
|
|
Line 38 use vars
|
Line 38 use vars
|
| qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
| %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
| %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
| %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); |
| |
|
|
Line 434 sub overloaderror {
|
Line 434 sub overloaderror {
|
| if ($overload>0) { |
if ($overload>0) { |
| $r->err_headers_out->{'Retry-After'}=$overload; |
$r->err_headers_out->{'Retry-After'}=$overload; |
| $r->log_error('Overload of '.$overload.' on '.$checkserver); |
$r->log_error('Overload of '.$overload.' on '.$checkserver); |
| return 413; |
return 409; |
| } |
} |
| return ''; |
return ''; |
| } |
} |
|
Line 1047 sub currentversion {
|
Line 1047 sub currentversion {
|
| sub subscribe { |
sub subscribe { |
| my $fname=shift; |
my $fname=shift; |
| if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
| |
$fname=~s/[\n\r]//g; |
| my $author=$fname; |
my $author=$fname; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
| my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
|
Line 1067 sub repcopy {
|
Line 1068 sub repcopy {
|
| my $filename=shift; |
my $filename=shift; |
| $filename=~s/\/+/\//g; |
$filename=~s/\/+/\//g; |
| if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } |
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } |
| |
$filename=~s/[\n\r]//g; |
| my $transname="$filename.in.transfer"; |
my $transname="$filename.in.transfer"; |
| if ((-e $filename) || (-e $transname)) { return OK; } |
if ((-e $filename) || (-e $transname)) { return OK; } |
| my $remoteurl=subscribe($filename); |
my $remoteurl=subscribe($filename); |
|
Line 1131 sub ssi_body {
|
Line 1133 sub ssi_body {
|
| my ($filelink,%form)=@_; |
my ($filelink,%form)=@_; |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
| &ssi($filelink,%form)); |
&ssi($filelink,%form)); |
| $output=~s/^.*?\<body[^\>]*\>//si; |
|
| $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
|
| $output=~ |
$output=~ |
| s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
| |
$output=~s/^.*?\<body[^\>]*\>//si; |
| |
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
| return $output; |
return $output; |
| } |
} |
| |
|
|
Line 1267 sub process_coursefile {
|
Line 1269 sub process_coursefile {
|
| # input: name of form element, coursedoc=1 means this is for the course |
# input: name of form element, coursedoc=1 means this is for the course |
| # output: url of file in userspace |
# output: url of file in userspace |
| |
|
| sub userfileupload { |
sub clean_filename { |
| my ($formname,$coursedoc,$subdir)=@_; |
my ($fname)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
|
| my $fname=$ENV{'form.'.$formname.'.filename'}; |
|
| # Replace Windows backslashes by forward slashes |
# Replace Windows backslashes by forward slashes |
| $fname=~s/\\/\//g; |
$fname=~s/\\/\//g; |
| # Get rid of everything but the actual filename |
# Get rid of everything but the actual filename |
|
Line 1279 sub userfileupload {
|
Line 1279 sub userfileupload {
|
| $fname=~s/\s+/\_/g; |
$fname=~s/\s+/\_/g; |
| # Replace all other weird characters by nothing |
# Replace all other weird characters by nothing |
| $fname=~s/[^\w\.\-]//g; |
$fname=~s/[^\w\.\-]//g; |
| |
return $fname; |
| |
} |
| |
|
| |
sub userfileupload { |
| |
my ($formname,$coursedoc,$subdir)=@_; |
| |
if (!defined($subdir)) { $subdir='unknown'; } |
| |
my $fname=$ENV{'form.'.$formname.'.filename'}; |
| |
$fname=&clean_filename($fname); |
| # See if there is anything left |
# See if there is anything left |
| unless ($fname) { return 'error: no uploaded file'; } |
unless ($fname) { return 'error: no uploaded file'; } |
| chop($ENV{'form.'.$formname}); |
chop($ENV{'form.'.$formname}); |
| |
if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently |
| |
my $now = time; |
| |
my $filepath = 'tmp/helprequests/'.$now; |
| |
my @parts=split(/\//,$filepath); |
| |
my $fullpath = $perlvar{'lonDaemons'}; |
| |
for (my $i=0;$i<@parts;$i++) { |
| |
$fullpath .= '/'.$parts[$i]; |
| |
if ((-e $fullpath)!=1) { |
| |
mkdir($fullpath,0777); |
| |
} |
| |
} |
| |
open(my $fh,'>'.$fullpath.'/'.$fname); |
| |
print $fh $ENV{'form.'.$formname}; |
| |
close($fh); |
| |
return $fullpath.'/'.$fname; |
| |
} |
| # Create the directory if not present |
# Create the directory if not present |
| my $docuname=''; |
my $docuname=''; |
| my $docudom=''; |
my $docudom=''; |
|
Line 1356 sub removeuserfile {
|
Line 1380 sub removeuserfile {
|
| return &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
return &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
| } |
} |
| |
|
| |
sub mkdiruserfile { |
| |
my ($docuname,$docudom,$dir)=@_; |
| |
my $home=&homeserver($docuname,$docudom); |
| |
return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home); |
| |
} |
| |
|
| |
sub renameuserfile { |
| |
my ($docuname,$docudom,$old,$new)=@_; |
| |
my $home=&homeserver($docuname,$docudom); |
| |
return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. |
| |
&escape("$new"),$home); |
| |
} |
| |
|
| # ------------------------------------------------------------------------- Log |
# ------------------------------------------------------------------------- Log |
| |
|
| sub log { |
sub log { |
|
Line 1395 sub flushcourselogs {
|
Line 1432 sub flushcourselogs {
|
| } |
} |
| if ($courseidbuffer{$coursehombuf{$crsid}}) { |
if ($courseidbuffer{$coursehombuf{$crsid}}) { |
| $courseidbuffer{$coursehombuf{$crsid}}.='&'. |
$courseidbuffer{$coursehombuf{$crsid}}.='&'. |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
| |
'='.&escape($courseinstcodebuf{$crsid}); |
| } else { |
} else { |
| $courseidbuffer{$coursehombuf{$crsid}}= |
$courseidbuffer{$coursehombuf{$crsid}}= |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
| |
'='.&escape($courseinstcodebuf{$crsid}); |
| } |
} |
| } |
} |
| # |
# |
|
Line 1472 sub courselog {
|
Line 1511 sub courselog {
|
| $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
| $coursedescrbuf{$ENV{'request.course.id'}}= |
$coursedescrbuf{$ENV{'request.course.id'}}= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
| |
$courseinstcodebuf{$ENV{'request.course.id'}}= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; |
| if (defined $courselogs{$ENV{'request.course.id'}}) { |
if (defined $courselogs{$ENV{'request.course.id'}}) { |
| $courselogs{$ENV{'request.course.id'}}.='&'.$what; |
$courselogs{$ENV{'request.course.id'}}.='&'.$what; |
| } else { |
} else { |
|
Line 1596 sub getannounce {
|
Line 1637 sub getannounce {
|
| if ($announcement=~/\w/) { |
if ($announcement=~/\w/) { |
| return |
return |
| '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. |
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. |
| '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>'; |
'<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; |
| } else { |
} else { |
| return ''; |
return ''; |
| } |
} |
|
Line 1615 sub courseidput {
|
Line 1656 sub courseidput {
|
| } |
} |
| |
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter)=@_; |
my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
| foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
| if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { |
| foreach ( |
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
| split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
foreach ( |
| |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
| $sincefilter.':'.&escape($descfilter), |
$sincefilter.':'.&escape($descfilter), |
| $tryserver))) { |
$tryserver))) { |
| my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
| if (($key) && ($value)) { |
if (($key) && ($value)) { |
| $returnhash{&unescape($key)}=&unescape($value); |
$returnhash{&unescape($key)}=$value; |
| |
} |
| } |
} |
| } |
} |
| |
|
| } |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 1638 sub courseiddump {
|
Line 1680 sub courseiddump {
|
| # |
# |
| # ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Check out an item |
| |
|
| |
sub get_first_access { |
| |
my ($type,$argsymb)=@_; |
| |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
| |
if ($argsymb) { $symb=$argsymb; } |
| |
my ($map,$id,$res)=&decode_symb($symb); |
| |
if ($type eq 'map') { $res=$map; } |
| |
my %times=&get('firstaccesstimes',[$res],$udom,$uname); |
| |
return $times{$res}; |
| |
} |
| |
|
| |
sub set_first_access { |
| |
my ($type)=@_; |
| |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
| |
my ($map,$id,$res)=&decode_symb($symb); |
| |
if ($type eq 'map') { $res=$map; } |
| |
my $firstaccess=&get_first_access($type); |
| |
if (!$firstaccess) { |
| |
return &put('firstaccesstimes',{$res=>time},$udom,$uname); |
| |
} |
| |
return 'already_set'; |
| |
} |
| |
|
| sub checkout { |
sub checkout { |
| my ($symb,$tuname,$tudom,$tcrsid)=@_; |
my ($symb,$tuname,$tudom,$tcrsid)=@_; |
| my $now=time; |
my $now=time; |
|
Line 2548 sub put {
|
Line 2612 sub put {
|
| return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
| } |
} |
| |
|
| |
# ---------------------------------------------------------- putstore interface |
| |
|
| |
sub putstore { |
| |
my ($namespace,$storehash,$udomain,$uname)=@_; |
| |
if (!$udomain) { $udomain=$ENV{'user.domain'}; } |
| |
if (!$uname) { $uname=$ENV{'user.name'}; } |
| |
my $uhome=&homeserver($uname,$udomain); |
| |
my $items=''; |
| |
my %allitems = (); |
| |
foreach (keys %$storehash) { |
| |
if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { |
| |
my $key = $1.':keys:'.$2; |
| |
$allitems{$key} .= $3.':'; |
| |
} |
| |
$items.=$_.'='.&escape($$storehash{$_}).'&'; |
| |
} |
| |
foreach (keys %allitems) { |
| |
$allitems{$_} =~ s/\:$//; |
| |
$items.= $_.'='.$allitems{$_}.'&'; |
| |
} |
| |
$items=~s/\&$//; |
| |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
| |
} |
| |
|
| # ------------------------------------------------------ critical put interface |
# ------------------------------------------------------ critical put interface |
| |
|
| sub cput { |
sub cput { |
|
Line 2630 sub allowed {
|
Line 2718 sub allowed {
|
| |
|
| if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } |
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } |
| # Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
| |
if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) |
| if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
|| ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
| return 'F'; |
return 'F'; |
| } |
} |
| |
|
|
Line 3031 sub log_query {
|
Line 3119 sub log_query {
|
| return get_query_reply($queryid); |
return get_query_reply($queryid); |
| } |
} |
| |
|
| |
# ------- Request retrieval of institutional classlists for course(s) |
| |
|
| |
sub fetch_enrollment_query { |
| |
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
| |
my $homeserver; |
| |
if ($context eq 'automated') { |
| |
$homeserver = $perlvar{'lonHostID'}; |
| |
} else { |
| |
$homeserver = &homeserver($cnum,$dom); |
| |
} |
| |
my $host=$hostname{$homeserver}; |
| |
my $cmd = ''; |
| |
foreach (keys %{$affiliatesref}) { |
| |
$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; |
| |
} |
| |
$cmd =~ s/%%$//; |
| |
$cmd = &escape($cmd); |
| |
my $query = 'fetchenrollment'; |
| |
my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); |
| |
unless ($queryid=~/^\Q$host\E\_/) { |
| |
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
| |
return 'error: '.$queryid; |
| |
} |
| |
my $reply = &get_query_reply($queryid); |
| |
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
| |
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum); |
| |
} else { |
| |
my @responses = split/:/,$reply; |
| |
if ($homeserver eq $perlvar{'lonHostID'}) { |
| |
foreach (@responses) { |
| |
my ($key,$value) = split/=/,$_; |
| |
$$replyref{$key} = $value; |
| |
} |
| |
} else { |
| |
my $pathname = $perlvar{'lonDaemons'}.'/tmp'; |
| |
foreach (@responses) { |
| |
my ($key,$value) = split/=/,$_; |
| |
$$replyref{$key} = $value; |
| |
if ($value > 0) { |
| |
foreach (@{$$affiliatesref{$key}}) { |
| |
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; |
| |
my $destname = $pathname.'/'.$filename; |
| |
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); |
| |
if ($xml_classlist =~ /^error/) { |
| |
&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); |
| |
} else { |
| |
if ( open(FILE,">$destname") ) { |
| |
print FILE &unescape($xml_classlist); |
| |
close(FILE); |
| |
} else { |
| |
&logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return 'ok'; |
| |
} |
| |
return 'error'; |
| |
} |
| |
|
| sub get_query_reply { |
sub get_query_reply { |
| my $queryid=shift; |
my $queryid=shift; |
| my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; |
my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; |
|
Line 3075 sub userlog_query {
|
Line 3225 sub userlog_query {
|
| return &log_query($uname,$udom,'userlog',%filters); |
return &log_query($uname,$udom,'userlog',%filters); |
| } |
} |
| |
|
| |
#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course |
| |
|
| |
sub auto_run { |
| |
my ($cnum,$cdom) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $response = &reply('autorun:'.$cdom,$homeserver); |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_get_sections { |
| |
my ($cnum,$cdom,$inst_coursecode) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my @secs = (); |
| |
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); |
| |
unless ($response eq 'refused') { |
| |
@secs = split/:/,$response; |
| |
} |
| |
return @secs; |
| |
} |
| |
|
| |
sub auto_new_course { |
| |
my ($cnum,$cdom,$inst_course_id,$owner) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_validate_courseID { |
| |
my ($cnum,$cdom,$inst_course_id) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_create_password { |
| |
my ($cnum,$cdom,$authparam) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $create_passwd = 0; |
| |
my $authchk = ''; |
| |
my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); |
| |
if ($response eq 'refused') { |
| |
$authchk = 'refused'; |
| |
} else { |
| |
($authparam,$create_passwd,$authchk) = split/:/,$response; |
| |
} |
| |
return ($authparam,$create_passwd,$authchk); |
| |
} |
| |
|
| |
sub auto_instcode_format { |
| |
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; |
| |
my $courses = ''; |
| |
my $homeserver; |
| |
if ($caller eq 'global') { |
| |
$homeserver = $perlvar{'lonHostID'}; |
| |
} else { |
| |
$homeserver = &homeserver($caller,$codedom); |
| |
} |
| |
my $host=$hostname{$homeserver}; |
| |
foreach (keys %{$instcodes}) { |
| |
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
| |
} |
| |
chop($courses); |
| |
my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
| |
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; |
| |
%{$codes} = &str2hash($codes_str); |
| |
@{$codetitles} = &str2array($codetitles_str); |
| |
%{$cat_titles} = &str2hash($cat_titles_str); |
| |
%{$cat_order} = &str2hash($cat_order_str); |
| |
return 'ok'; |
| |
} |
| |
return $response; |
| |
} |
| |
|
| # ------------------------------------------------------------------ Plain Text |
# ------------------------------------------------------------------ Plain Text |
| |
|
| sub plaintext { |
sub plaintext { |
|
Line 3265 sub modifyuser {
|
Line 3489 sub modifyuser {
|
| |
|
| sub modifystudent { |
sub modifystudent { |
| my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
| $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_; |
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$ENV{'request.course.id'}) { |
unless ($cid=$ENV{'request.course.id'}) { |
| return 'not_in_class'; |
return 'not_in_class'; |
|
Line 3280 sub modifystudent {
|
Line 3504 sub modifystudent {
|
| # students environment |
# students environment |
| $uid = undef if (!$forceid); |
$uid = undef if (!$forceid); |
| $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
| $gene,$usec,$end,$start,$type,$cid); |
$gene,$usec,$end,$start,$type,$locktype,$cid); |
| return $reply; |
return $reply; |
| } |
} |
| |
|
| sub modify_student_enrollment { |
sub modify_student_enrollment { |
| my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, |
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; |
| $cid) = @_; |
|
| my ($cdom,$cnum,$chome); |
my ($cdom,$cnum,$chome); |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$ENV{'request.course.id'}) { |
unless ($cid=$ENV{'request.course.id'}) { |
|
Line 3332 sub modify_student_enrollment {
|
Line 3555 sub modify_student_enrollment {
|
| $first,$middle); |
$first,$middle); |
| my $reply=cput('classlist', |
my $reply=cput('classlist', |
| {"$uname:$udom" => |
{"$uname:$udom" => |
| join(':',$end,$start,$uid,$usec,$fullname,$type) }, |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
| $cdom,$cnum); |
$cdom,$cnum); |
| unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
| return 'error: '.$reply; |
return 'error: '.$reply; |
|
Line 3368 sub writecoursepref {
|
Line 3591 sub writecoursepref {
|
| # ---------------------------------------------------------- Make/modify course |
# ---------------------------------------------------------- Make/modify course |
| |
|
| sub createcourse { |
sub createcourse { |
| my ($udom,$description,$url,$course_server,$nonstandard)=@_; |
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_; |
| $url=&declutter($url); |
$url=&declutter($url); |
| my $cid=''; |
my $cid=''; |
| unless (&allowed('ccc',$udom)) { |
unless (&allowed('ccc',$udom)) { |
|
Line 3401 sub createcourse {
|
Line 3624 sub createcourse {
|
| return 'error: no such course'; |
return 'error: no such course'; |
| } |
} |
| # ----------------------------------------------------------------- Course made |
# ----------------------------------------------------------------- Course made |
| # log existance |
# log existence |
| &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), |
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). |
| $uhome); |
'='.&escape($inst_code),$uhome); |
| &flushcourselogs(); |
&flushcourselogs(); |
| # set toplevel url |
# set toplevel url |
| my $topurl=$url; |
my $topurl=$url; |
|
Line 3456 sub revokecustomrole {
|
Line 3679 sub revokecustomrole {
|
| $deleteflag); |
$deleteflag); |
| } |
} |
| |
|
| |
|
| |
# ------------------------------------------------------------ Portfolio Director Lister |
| |
# returns listing of contents of user's /userfiles/portfolio/ directory |
| |
# |
| |
|
| |
sub portfoliolist { |
| |
my ($currentPath, $currentFile) = @_; |
| |
my ($udom, $uname, $portfolioRoot); |
| |
$uname=$ENV{'user.name'}; |
| |
$udom=$ENV{'user.domain'}; |
| |
# really should interrogate the system for home directory information, but . . . |
| |
$portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/'; |
| |
$uname =~ /^(.?)(.?)(.?)/; |
| |
$portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio'; |
| |
my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom)); |
| |
return $listing; |
| |
} |
| |
|
| |
sub portfoliomanage { |
| |
|
| |
#FIXME please user the existing remove userfile function instead and |
| |
#add a userfilerename functions. |
| |
#FIXME uhome should never be an argument to any lonnet functions |
| |
|
| |
# handles deleting and renaming files in user's userfiles/portfolio/ directory |
| |
# |
| |
my ($filename, $fileaction, $filenewname) = @_; |
| |
my ($udom, $uname, $uhome); |
| |
$uname=$ENV{'user.name'}; |
| |
$udom=$ENV{'user.domain'}; |
| |
$uhome=$ENV{'user.home'}; |
| |
my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome); |
| |
return $listing; |
| |
} |
| |
|
| |
|
| # ------------------------------------------------------------ Directory lister |
# ------------------------------------------------------------ Directory lister |
| |
|
| sub dirlist { |
sub dirlist { |
|
Line 3959 sub metadata {
|
Line 4218 sub metadata {
|
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| # if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
| if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || |
if (($uri eq '') || |
| |
(($uri =~ m|^/*adm/|) && |
| |
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || |
| ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
| ($uri =~ m|home/[^/]+/public_html/|)) { |
($uri =~ m|home/[^/]+/public_html/|)) { |
| return undef; |
return undef; |
|
Line 4251 sub symblist {
|
Line 4512 sub symblist {
|
| # --------------------------------------------------------------- Verify a symb |
# --------------------------------------------------------------- Verify a symb |
| |
|
| sub symbverify { |
sub symbverify { |
| my ($symb,$thisfn)=@_; |
my ($symb,$thisurl)=@_; |
| |
my $thisfn=$thisurl; |
| |
# wrapper not part of symbs |
| |
$thisfn=~s/^\/adm\/wrapper//; |
| $thisfn=&declutter($thisfn); |
$thisfn=&declutter($thisfn); |
| # direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
| if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
|
Line 4261 sub symbverify {
|
Line 4525 sub symbverify {
|
| unless ($url eq $thisfn) { return 0; } |
unless ($url eq $thisfn) { return 0; } |
| |
|
| $symb=&symbclean($symb); |
$symb=&symbclean($symb); |
| |
$thisurl=&deversion($thisurl); |
| $thisfn=&deversion($thisfn); |
$thisfn=&deversion($thisfn); |
| |
|
| my %bighash; |
my %bighash; |
|
Line 4268 sub symbverify {
|
Line 4533 sub symbverify {
|
| |
|
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
| my $ids=$bighash{'ids_'.&clutter($thisfn)}; |
my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
| unless ($ids) { |
unless ($ids) { |
| $ids=$bighash{'ids_/'.$thisfn}; |
$ids=$bighash{'ids_/'.$thisurl}; |
| } |
} |
| if ($ids) { |
if ($ids) { |
| # ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
|
Line 4299 sub symbclean {
|
Line 4564 sub symbclean {
|
| # remove version from URL |
# remove version from URL |
| $symb=~s/\.(\d+)\.(\w+)$/\.$2/; |
$symb=~s/\.(\d+)\.(\w+)$/\.$2/; |
| |
|
| |
# remove wrapper |
| |
|
| |
$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; |
| return $symb; |
return $symb; |
| } |
} |
| |
|
|
Line 4462 sub numval2 {
|
Line 4730 sub numval2 {
|
| } |
} |
| |
|
| sub latest_rnd_algorithm_id { |
sub latest_rnd_algorithm_id { |
| return '64bit2'; |
return '64bit3'; |
| |
} |
| |
|
| |
sub get_rand_alg { |
| |
my ($courseid)=@_; |
| |
if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } |
| |
if ($courseid) { |
| |
return $ENV{"course.$courseid.rndseed"}; |
| |
} |
| |
return &latest_rnd_algorithm_id(); |
| } |
} |
| |
|
| sub getCODE { |
sub getCODE { |
|
Line 4484 sub rndseed {
|
Line 4761 sub rndseed {
|
| if (!$courseid) { $courseid=$wcourseid; } |
if (!$courseid) { $courseid=$wcourseid; } |
| if (!$domain) { $domain=$wdomain; } |
if (!$domain) { $domain=$wdomain; } |
| if (!$username) { $username=$wusername } |
if (!$username) { $username=$wusername } |
| my $which=$ENV{"course.$courseid.rndseed"}; |
my $which=&get_rand_alg(); |
| if (defined(&getCODE())) { |
if (defined(&getCODE())) { |
| return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
| |
} elsif ($which eq '64bit3') { |
| |
return &rndseed_64bit3($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit2') { |
} elsif ($which eq '64bit2') { |
| return &rndseed_64bit2($symb,$courseid,$domain,$username); |
return &rndseed_64bit2($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit') { |
} elsif ($which eq '64bit') { |
|
Line 4554 sub rndseed_64bit2 {
|
Line 4833 sub rndseed_64bit2 {
|
| } |
} |
| } |
} |
| |
|
| |
sub rndseed_64bit3 { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| |
{ |
| |
use integer; |
| |
# strings need to be an even # of cahracters long, it it is odd the |
| |
# last characters gets thrown away |
| |
my $symbchck=unpack("%32S*",$symb.' ') << 21; |
| |
my $symbseed=numval2($symb) << 10; |
| |
my $namechck=unpack("%32S*",$username.' '); |
| |
|
| |
my $nameseed=numval2($username) << 21; |
| |
my $domainseed=unpack("%32S*",$domain.' ') << 10; |
| |
my $courseseed=unpack("%32S*",$courseid.' '); |
| |
|
| |
my $num1=$symbchck+$symbseed+$namechck; |
| |
my $num2=$nameseed+$domainseed+$courseseed; |
| |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
| |
return "$num1:$num2"; |
| |
} |
| |
} |
| |
|
| sub rndseed_CODE_64bit { |
sub rndseed_CODE_64bit { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| { |
{ |
|
Line 4567 sub rndseed_CODE_64bit {
|
Line 4868 sub rndseed_CODE_64bit {
|
| my $num2=$CODEseed+$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
| return "$num1,$num2"; |
return "$num1:$num2"; |
| } |
} |
| } |
} |
| |
|
| sub setup_random_from_rndseed { |
sub setup_random_from_rndseed { |
| my ($rndseed)=@_; |
my ($rndseed)=@_; |
| if ($rndseed =~/,/) { |
if ($rndseed =~/([,:])/) { |
| my ($num1,$num2)=split(/,/,$rndseed); |
my ($num1,$num2)=split(/[,:]/,$rndseed); |
| &Math::Random::random_set_seed(abs($num1),abs($num2)); |
&Math::Random::random_set_seed(abs($num1),abs($num2)); |
| } else { |
} else { |
| &Math::Random::random_set_seed_from_phrase($rndseed); |
&Math::Random::random_set_seed_from_phrase($rndseed); |
|
Line 4679 sub getfile {
|
Line 4980 sub getfile {
|
| if ($rtncode eq '404') { |
if ($rtncode eq '404') { |
| unlink($localfile); |
unlink($localfile); |
| } |
} |
| |
#my $ua=new LWP::UserAgent; |
| |
#my $request=new HTTP::Request('GET',&tokenwrapper($file)); |
| |
#my $response=$ua->request($request); |
| |
#if ($response->is_success()) { |
| |
# return $response->content; |
| |
# } else { |
| |
# return -1; |
| |
# } |
| return -1; |
return -1; |
| } |
} |
| if ($info < $fileinfo[9]) { |
if ($info < $fileinfo[9]) { |
|
Line 4692 sub getfile {
|
Line 5001 sub getfile {
|
| } else { |
} else { |
| $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
| if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
| return -1; |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',&tokenwrapper($file)); |
| |
my $response=$ua->request($request); |
| |
if ($response->is_success()) { |
| |
return $response->content; |
| |
} else { |
| |
return -1; |
| |
} |
| } |
} |
| my @parts = ($cdom,$cnum); |
my @parts = ($cdom,$cnum); |
| if ($filename =~ m|^(.+)/[^/]+$|) { |
if ($filename =~ m|^(.+)/[^/]+$|) { |
| push @parts, split(/\//,$1); |
push @parts, split(/\//,$1); |
| } |
} |
| foreach my $part (@parts) { |
foreach my $part (@parts) { |
| $path .= '/'.$part; |
$path .= '/'.$part; |
| if (!-e $path) { |
if (!-e $path) { |
|
Line 4714 sub getfile {
|
Line 5030 sub getfile {
|
| return $info; |
return $info; |
| } |
} |
| |
|
| |
sub tokenwrapper { |
| |
my $uri=shift; |
| |
$uri=~s/^http\:\/\/([^\/]+)//; |
| |
$uri=~s/^\///; |
| |
$ENV{'user.environment'}=~/\/([^\/]+)\.id/; |
| |
my $token=$1; |
| |
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { |
| |
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); |
| |
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. |
| |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| |
'&tokenissued='.$perlvar{'lonHostID'}; |
| |
} else { |
| |
return '/adm/notfound.html'; |
| |
} |
| |
} |
| |
|
| sub getuploaded { |
sub getuploaded { |
| my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
| $uri=~s/^\///; |
$uri=~s/^\///; |
|
Line 4751 sub filelocation {
|
Line 5083 sub filelocation {
|
| $location = $file; |
$location = $file; |
| $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
| } elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
| $location=$file; |
if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) { |
| |
$location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4; |
| |
if (not -e $location) { |
| |
$file=~/^\/uploaded\/(.*)$/; |
| |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1; |
| |
} |
| |
} elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) { |
| |
$location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3; |
| |
if (not -e $location) { |
| |
$file=~/^\/uploaded\/(.*)$/; |
| |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1; |
| |
} |
| |
} else { |
| |
$location=$file; |
| |
} |
| } else { |
} else { |
| $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| $file=~s:^/res/:/:; |
$file=~s:^/res/:/:; |
|
Line 4821 sub declutter {
|
Line 5167 sub declutter {
|
| |
|
| sub clutter { |
sub clutter { |
| my $thisfn='/'.&declutter(shift); |
my $thisfn='/'.&declutter(shift); |
| unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { |
unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { |
| $thisfn='/res'.$thisfn; |
$thisfn='/res'.$thisfn; |
| } |
} |
| return $thisfn; |
return $thisfn; |
|
Line 5642 put($namespace,$storehash,$udom,$uname)
|
Line 5988 put($namespace,$storehash,$udom,$uname)
|
| |
|
| =item * |
=item * |
| |
|
| |
putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp |
| |
keys used in storehash include version information (e.g., 1:$symb:message etc.) as |
| |
used in records written by &store and retrieved by &restore. This function |
| |
was created for use in editing discussion posts, without incrementing the |
| |
version number included in the key for a particular post. The colon |
| |
separated list of attribute names (e.g., the value associated with the key |
| |
1:keys:$symb) is also generated and passed in the ampersand separated |
| |
items sent to lonnet::reply(). |
| |
|
| |
=item * |
| |
|
| cput($namespace,$storehash,$udom,$uname) : critical put |
cput($namespace,$storehash,$udom,$uname) : critical put |
| ($udom and $uname are optional) |
($udom and $uname are optional) |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl