loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.999 and 1.1024

version 1.999, 2009/05/08 14:33:16	version 1.1024, 2009/08/28 19:43:10
Line 92 use Time::HiRes qw( gettimeofday tv_inte	Line 92 use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;	use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
use Math::Random;	use Math::Random;
	use File::MMagic;
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;

Line 718 sub spareserver {	Line 719 sub spareserver {
if ($protocol{$spare_server} eq 'https') {	if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};	$protocol = $protocol{$spare_server};
}	}
$spare_server = $protocol.'://'.&hostname($spare_server);	if (defined($spare_server)) {
	my $hostname = &hostname($spare_server);
	if (defined($hostname)) {
	$spare_server = $protocol.'://'.$hostname;
	}
	}
}	}
return $spare_server;	return $spare_server;
}	}
Line 953 sub idput {	Line 959 sub idput {
}	}
}	}

# ------------------------------------------- get items from domain db files	# ------------------------------dump from db file owned by domainconfig user
	sub dump_dom {
	my ($namespace,$udom,$regexp,$range)=@_;
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	my %returnhash;
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	%returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
	}
	return %returnhash;
	}

	# ------------------------------------------ get items from domain db files

sub get_dom {	sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;	my ($namespace,$storearr,$udom,$uhome)=@_;
Line 1027 sub put_dom {	Line 1047 sub put_dom {
}	}
}	}

	# --------------------- newput for items in db file owned by domainconfig user
	sub newput_dom {
	my ($namespace,$storehash,$udom) = @_;
	my $result;
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	$result = &newput($namespace,$storehash,$udom,$uname);
	}
	return $result;
	}

	# --------------------- delete for items in db file owned by domainconfig user
	sub del_dom {
	my ($namespace,$storearr,$udom)=@_;
	if (ref($storearr) eq 'ARRAY') {
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	return &del($namespace,$storearr,$udom,$uname);
	}
	}
	}

	# ----------------------------------construct domainconfig user for a domain
	sub get_domainconfiguser {
	my ($udom) = @_;
	return $udom.'-domainconfig';
	}

sub retrieve_inst_usertypes {	sub retrieve_inst_usertypes {
my ($udom) = @_;	my ($udom) = @_;
my (%returnhash,@order);	my (%returnhash,@order);
Line 1321 sub get_domain_defaults {	Line 1375 sub get_domain_defaults {
}	}
}	}
if (ref($domconfig{'requestcourses'}) eq 'HASH') {	if (ref($domconfig{'requestcourses'}) eq 'HASH') {
foreach my $item ('official','unofficial') {	foreach my $item ('official','unofficial','community') {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};	$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}	}
}	}
Line 1660 sub userenvironment {	Line 1714 sub userenvironment {
}	}
$items=~s/\&$//;	$items=~s/\&$//;
my %returnhash=();	my %returnhash=();
my @answer=split(/\&/,	my $uhome = &homeserver($unam,$udom);
&reply('get:'.$udom.':'.$unam.':environment:'.$items,	unless ($uhome eq 'no_host') {
&homeserver($unam,$udom)));	my @answer=split(/\&/,
my $i;	&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
for ($i=0;$i<=$#what;$i++) {	my $i;
$returnhash{$what[$i]}=&unescape($answer[$i]);	for ($i=0;$i<=$#what;$i++) {
	$returnhash{$what[$i]}=&unescape($answer[$i]);
	}
}	}
return %returnhash;	return %returnhash;
}	}
Line 1861 sub ssi_body {	Line 1917 sub ssi_body {
if ($filelink=~/^https?\:/) {	if ($filelink=~/^https?\:/) {
($output,$response)=&externalssi($filelink);	($output,$response)=&externalssi($filelink);
} else {	} else {
	$filelink .= $filelink=~/\?/ ? '&' : '?';
	$filelink .= 'inhibitmenu=yes';
($output,$response)=&ssi($filelink,%form);	($output,$response)=&ssi($filelink,%form);
}	}
$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;	$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;
Line 1904 sub ssi {	Line 1962 sub ssi {
&Apache::lonenc::check_encrypt(\$fn);	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);	$request=new HTTP::Request('POST',&absolute_url().$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));	$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
} else {	} else {
$request=new HTTP::Request('GET',&absolute_url().$fn);	$request=new HTTP::Request('GET',&absolute_url().$fn);
}	}
Line 2002 sub process_coursefile {	Line 2060 sub process_coursefile {
print $fh $env{'form.'.$source};	print $fh $env{'form.'.$source};
close($fh);	close($fh);
if ($parser eq 'parse') {	if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);	my $mm = new File::MMagic;
unless ($parse_result eq 'ok') {	my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);	if ($mime_type eq 'text/html') {
	my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
	unless ($parse_result eq 'ok') {
	&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
	}
}	}
}	}
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
Line 2246 sub finishuserfileupload {	Line 2308 sub finishuserfileupload {
}	}
}	}
if ($parser eq 'parse') {	if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,	my $mm = new File::MMagic;
$codebase);	my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
unless ($parse_result eq 'ok') {	if ($mime_type eq 'text/html') {
&logthis('Failed to parse '.$filepath.$file.	my $parse_result = &extract_embedded_items($filepath.'/'.$file,
' for embedded media: '.$parse_result);	$allfiles,$codebase);
	unless ($parse_result eq 'ok') {
	&logthis('Failed to parse '.$filepath.$file.
	' for embedded media: '.$parse_result);
	}
}	}
}	}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
Line 2554 sub flushcourselogs {	Line 2620 sub flushcourselogs {
# Reverse lookup of domain roles (dc, ad, li, sc, au)	# Reverse lookup of domain roles (dc, ad, li, sc, au)
#	#
my %domrolebuffer = ();	my %domrolebuffer = ();
foreach my $entry (keys %domainrolehash) {	foreach my $entry (keys(%domainrolehash)) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);	my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
if ($domrolebuffer{$rudom}) {	if ($domrolebuffer{$rudom}) {
$domrolebuffer{$rudom}.='&'.&escape($entry).	$domrolebuffer{$rudom}.='&'.&escape($entry).
Line 2735 sub get_course_adv_roles {	Line 2801 sub get_course_adv_roles {
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});	&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;	my $now=time;
my %privileged;	my %privileged;
foreach my $entry (keys %dumphash) {	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
Line 2961 sub courseidput {	Line 3027 sub courseidput {
sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,	$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
$selfenrollonly,$catfilter,$showhidden,$caller)=@_;	$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,$cloneonly)=@_;
my $as_hash = 1;	my $as_hash = 1;
my %returnhash;	my %returnhash;
if (!$domfilter) { $domfilter=''; }	if (!$domfilter) { $domfilter=''; }
Line 2980 sub courseiddump {	Line 3046 sub courseiddump {
':'.&escape($coursefilter).':'.&escape($typefilter).	':'.&escape($coursefilter).':'.&escape($typefilter).
':'.&escape($regexp_ok).':'.$as_hash.':'.	':'.&escape($regexp_ok).':'.$as_hash.':'.
&escape($selfenrollonly).':'.&escape($catfilter).':'.	&escape($selfenrollonly).':'.&escape($catfilter).':'.
$showhidden.':'.$caller,$tryserver);	$showhidden.':'.$caller.':'.&escape($cloner).':'.
	&escape($cc_clone).':'.$cloneonly,$tryserver);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {	foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);	my ($key,$value)=split(/\=/,$item,2);
Line 2995 sub courseiddump {	Line 3062 sub courseiddump {
for (my $i=0; $i<@responses; $i++) {	for (my $i=0; $i<@responses; $i++) {
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);	$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
}	}
}	}
}	}
}	}
}	}
Line 3035 sub dcmaildump {	Line 3102 sub dcmaildump {

sub get_domain_roles {	sub get_domain_roles {
my ($dom,$roles,$startdate,$enddate)=@_;	my ($dom,$roles,$startdate,$enddate)=@_;
if (undef($startdate) \|\| $startdate eq '') {	if ((!defined($startdate)) \|\| ($startdate eq '')) {
$startdate = '.';	$startdate = '.';
}	}
if (undef($enddate) \|\| $enddate eq '') {	if ((!defined($enddate)) \|\| ($enddate eq '')) {
$enddate = '.';	$enddate = '.';
}	}
my $rolelist;	my $rolelist;
Line 3445 sub tmpreset {	Line 3512 sub tmpreset {
if (tie(%hash,'GDBM_File',	if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',	$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach my $key (keys %hash) {	foreach my $key (keys(%hash)) {
if ($key=~ /:$symb/) {	if ($key=~ /:$symb/) {
delete($hash{$key});	delete($hash{$key});
}	}
Line 3881 sub set_userprivs {	Line 3948 sub set_userprivs {
my $adv=0;	my $adv=0;
my %grouproles = ();	my %grouproles = ();
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {	foreach my $role (keys(%{$allroles})) {
my ($trole,$area,$sec,$extendedarea);	my ($trole,$area,$sec,$extendedarea);
if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {	if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
$trole = $1;	$trole = $1;
Line 3925 sub set_userprivs {	Line 3992 sub set_userprivs {
}	}

sub role_status {	sub role_status {
my ($rolekey,$then,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;	my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
my @pwhere = ();	my @pwhere = ();
if (exists($env{$rolekey}) && $env{$rolekey} ne '') {	if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);	(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
Line 3936 sub role_status {	Line 4003 sub role_status {
$$tstatus='is';	$$tstatus='is';
if ($$tstart && $$tstart>$then) {	if ($$tstart && $$tstart>$then) {
$$tstatus='future';	$$tstatus='future';
if ($$tstart<$now) { $$tstatus='will'; }	if ($$tstart && $$tstart>$refresh) {
	if ($$tstart<$now) {
	if (($$where ne '') && ($$role ne '')) {
	my (%allroles,%allgroups,$group_privs);
	my %userroles = (
	'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
	);
	my $spec=$$role.'.'.$$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\//) {
	&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
	} elsif ($$role eq 'gr') {
	my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
	$env{'user.name'});
	my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
	(undef,my $group_privs) = split(/\//,$trole);
	$group_privs = &unescape($group_privs);
	&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
	} else {
	&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
	}
	my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
	&appenv(\%userroles,[$$role,'cm']);
	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
	$$tstatus = 'is';
	}
	}
	}
}	}
if ($$tend) {	if ($$tend) {
if ($$tend<$then) {	if ($$tend<$then) {
Line 3950 sub role_status {	Line 4051 sub role_status {
}	}

sub check_adhoc_privs {	sub check_adhoc_privs {
my ($cdom,$cnum,$then,$now,$checkrole) = @_;	my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;	my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
if ($env{$cckey}) {	if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);	my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
&role_status($cckey,$then,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);	&role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {	unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {
&set_adhoc_privileges($cdom,$cnum,$checkrole);	&set_adhoc_privileges($cdom,$cnum,$checkrole);
}	}
Line 4594 sub usertools_access {	Line 4695 sub usertools_access {
%tools = (	%tools = (
official => 1,	official => 1,
unofficial => 1,	unofficial => 1,
	community => 1,
);	);
} else {	} else {
%tools = (	%tools = (
Line 5041 sub allowed {	Line 5143 sub allowed {

my $envkey;	my $envkey;
if ($thisallowed=~/L/) {	if ($thisallowed=~/L/) {
foreach $envkey (keys %env) {	foreach $envkey (keys(%env)) {
if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {	if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {
my $courseid=$2;	my $courseid=$2;
my $roleid=$1.'.'.$2;	my $roleid=$1.'.'.$2;
Line 5332 sub fetch_enrollment_query {	Line 5434 sub fetch_enrollment_query {
}	}
my $host=&hostname($homeserver);	my $host=&hostname($homeserver);
my $cmd = '';	my $cmd = '';
foreach my $affiliate (keys %{$affiliatesref}) {	foreach my $affiliate (keys(%{$affiliatesref})) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}	}
$cmd =~ s/%%$//;	$cmd =~ s/%%$//;
Line 5465 sub auto_run {	Line 5567 sub auto_run {

sub auto_get_sections {	sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;	my ($cnum,$cdom,$inst_coursecode) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver;
my @secs = ();	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));	$homeserver = &homeserver($cnum,$cdom);
unless ($response eq 'refused') {	}
@secs = split(/:/,$response);	if (!defined($homeserver)) {
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	}
	my @secs;
	if (defined($homeserver)) {
	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
	unless ($response eq 'refused') {
	@secs = split(/:/,$response);
	}
}	}
return @secs;	return @secs;
}	}
Line 5488 sub auto_validate_courseID {	Line 5600 sub auto_validate_courseID {
return $response;	return $response;
}	}

	sub auto_validate_instcode {
	my ($cnum,$cdom,$instcode,$owner) = @_;
	my ($homeserver,$response);
	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
	$homeserver = &homeserver($cnum,$cdom);
	}
	if (!defined($homeserver)) {
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	}
	my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
	&escape($instcode).':'.&escape($owner),$homeserver));
	return $response;
	}

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;	my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);	my ($homeserver,$response);
Line 5602 sub auto_instcode_format {	Line 5730 sub auto_instcode_format {
push(@homeservers,$tryserver);	push(@homeservers,$tryserver);
}	}
}	}
	} elsif ($caller eq 'requests') {
	if ($codedom =~ /^$match_domain$/) {
	my $chome = &domain($codedom,'primary');
	unless ($chome eq 'no_host') {
	push(@homeservers,$chome);
	}
	}
} else {	} else {
push(@homeservers,&homeserver($caller,$codedom));	push(@homeservers,&homeserver($caller,$codedom));
}	}
Line 5659 sub auto_instcode_defaults {	Line 5794 sub auto_instcode_defaults {
}	}

return $response;	return $response;
}	}

	sub auto_possible_instcodes {
	my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
	unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') &&
	(ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
	return;
	}
	my (@homeservers,$uhome);
	if (defined(&domain($domain,'primary'))) {
	$uhome=&domain($domain,'primary');
	push(@homeservers,&domain($domain,'primary'));
	} else {
	my %servers = &get_servers($domain,'library');
	foreach my $tryserver (keys(%servers)) {
	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
	push(@homeservers,$tryserver);
	}
	}
	}
	my $response;
	foreach my $server (@homeservers) {
	$response=&reply('autopossibleinstcodes:'.$domain,$server);
	next if ($response =~ /(con_lost\|error\|no_such_host\|refused)/);
	my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) =
	split(':',$response);
	@{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
	@{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
	foreach my $item (split('&',$cat_title)) {
	my ($name,$value)=split('=',$item);
	$cat_titles->{&unescape($name)}=&thaw_unescape($value);
	}
	foreach my $item (split('&',$cat_order)) {
	my ($name,$value)=split('=',$item);
	$cat_orders->{&unescape($name)}=&thaw_unescape($value);
	}
	return 'ok';
	}
	return $response;
	}

	sub auto_courserequest_checks {
	my ($dom) = @_;
	my ($homeserver,%validations);
	if ($dom =~ /^$match_domain$/) {
	$homeserver = &domain($dom,'primary');
	}
	unless ($homeserver eq 'no_host') {
	my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
	my @items = split(/&/,$response);
	foreach my $item (@items) {
	my ($key,$value) = split('=',$item);
	$validations{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	return %validations;
	}

	sub auto_courserequest_validation {
	my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
	my ($homeserver,$response);
	if ($dom =~ /^$match_domain$/) {
	$homeserver = &domain($dom,'primary');
	}
	unless ($homeserver eq 'no_host') {

	$response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
	':'.&escape($crstype).':'.&escape($inststatuslist).
	':'.&escape($instcode).':'.&escape($instseclist),
	$homeserver));
	}
	return $response;
	}

sub auto_validate_class_sec {	sub auto_validate_class_sec {
my ($cdom,$cnum,$owners,$inst_class) = @_;	my ($cdom,$cnum,$owners,$inst_class) = @_;
Line 5827 sub plaintext {	Line 6036 sub plaintext {
}	}
}	}
my %rolenames = (	my %rolenames = (
Course => 'std',	Course => 'std',
Group => 'alt1',	Community => 'alt1',
);	);
if (defined($type) &&	if (defined($type) &&
defined($rolenames{$type}) &&	defined($rolenames{$type}) &&
Line 5880 sub assignrole {	Line 6089 sub assignrole {
if ($refused) {	if ($refused) {
if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';	$refused = '';
} else {	} elsif ($context eq 'requestcourses') {
	if (($role eq 'cc') && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
	my ($cdom,$cnum) = ($cwosec =~ m{^/($match_domain)/($match_courseid)$});
	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if ($crsenv{'internal.courseowner'} eq
	$env{'user.name'}.':'.$env{'user.domain'}) {
	$refused = '';
	}
	}
	}
	if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
' '.$role.' '.$end.' '.$start.' by '.	' '.$role.' '.$end.' '.$start.' by '.
$env{'user.name'}.' at '.$env{'user.domain'});	$env{'user.name'}.' at '.$env{'user.domain'});
Line 6204 sub writecoursepref {	Line 6423 sub writecoursepref {

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
$course_owner,$crstype)=@_;	$course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	unless (&allowed('ccc',$udom)) {
return 'refused';	if ($context eq 'requestcourses') {
	unless (&usertools_access($course_owner,$udom,$category,undef,$context)) {
	return 'refused';
	}
	} else {
	return 'refused';
	}
}	}
# ------------------------------------------------------------------- Create ID	# --------------------------------------------------------------- Get Unique ID
my $uname=int(1+rand(9)).	my $uname;
('a'..'z','A'..'Z','0'..'9')[int(rand(62))].	if ($cnum =~ /^$match_courseid$/) {
substr($$.time,0,5).unpack("H8",pack("I32",time)).	my $chome=&homeserver($cnum,$udom,'true');
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	if (($chome eq '') \|\| ($chome eq 'no_host')) {
# ----------------------------------------------- Make sure that does not exist	$uname = $cnum;
my $uhome=&homeserver($uname,$udom,'true');	} else {
unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {	$uname = &generate_coursenum($udom);
$uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).	}
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	} else {
$uhome=&homeserver($uname,$udom,'true');	$uname = &generate_coursenum($udom);
unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {	}
return 'error: unable to generate unique course-ID';	return $uname if ($uname =~ /^error/);
}	# -------------------------------------------------- Check supplied server name
}
# ------------------------------------------------ Check supplied server name
$course_server = $env{'user.homeserver'} if (! defined($course_server));	$course_server = $env{'user.homeserver'} if (! defined($course_server));
if (! &is_library($course_server)) {	if (! &is_library($course_server)) {
return 'error:bad server name '.$course_server;	return 'error:bad server name '.$course_server;
Line 6234 sub createcourse {	Line 6457 sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',	my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$course_server);	$course_server);
unless ($reply eq 'ok') { return 'error: '.$reply; }	unless ($reply eq 'ok') { return 'error: '.$reply; }
$uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
return 'error: no such course';	return 'error: no such course';
}	}
Line 6275 ENDINITMAP	Line 6498 ENDINITMAP
return '/'.$udom.'/'.$uname;	return '/'.$udom.'/'.$uname;
}	}

	# ------------------------------------------------------------------- Create ID
	sub generate_coursenum {
	my ($udom) = @_;
	my $domdesc = &domain($udom);
	return 'error: invalid domain' if ($domdesc eq '');
	my $uname=int(1+rand(9)).
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	# ----------------------------------------------- Make sure that does not exist
	my $uhome=&homeserver($uname,$udom,'true');
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	$uname=int(1+rand(9)).
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	$uhome=&homeserver($uname,$udom,'true');
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	return 'error: unable to generate unique course-ID';
	}
	}
	return $uname;
	}

sub is_course {	sub is_course {
my ($cdom,$cnum) = @_;	my ($cdom,$cnum) = @_;
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,	my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
Line 6285 sub is_course {	Line 6532 sub is_course {
return 0;	return 0;
}	}

	sub store_userdata {
	my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
	my $result;
	if ($datakey ne '') {
	if (ref($storehash) eq 'HASH') {
	if ($udom eq '' \|\| $uname eq '') {
	$udom = $env{'user.domain'};
	$uname = $env{'user.name'};
	}
	my $uhome=&homeserver($uname,$udom);
	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	$result = 'error: no_host';
	} else {
	$storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
	$storehash->{'host'} = $perlvar{'lonHostID'};

	my $namevalue='';
	foreach my $key (keys(%{$storehash})) {
	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
	}
	$namevalue=~s/\&$//;
	$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
	"$namespace:$datakey:$namevalue",$uhome);
	}
	} else {
	$result = 'error: data to store was not a hash reference';
	}
	} else {
	$result= 'error: invalid requestkey';
	}
	return $result;
	}

# ---------------------------------------------------------- Assign Custom Role	# ---------------------------------------------------------- Assign Custom Role

sub assigncustomrole {	sub assigncustomrole {
Line 7774 sub devalidate_title_cache {	Line 8054 sub devalidate_title_cache {
&devalidate_cache_new('title',$key);	&devalidate_cache_new('title',$key);
}	}

	# ------------------------------------------------- Get the title of a course

	sub current_course_title {
	return $env{ 'course.' . $env{'request.course.id'} . '.description' };
	}
# ------------------------------------------------- Get the title of a resource	# ------------------------------------------------- Get the title of a resource

sub gettitle {	sub gettitle {
Line 7840 sub symblist {	Line 8125 sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {	if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach my $url (keys %newhash) {	foreach my $url (keys(%newhash)) {
next if ($url eq 'last_known'	next if ($url eq 'last_known'
&& $env{'form.no_update_last_known'});	&& $env{'form.no_update_last_known'});
$hash{declutter($url)}=&encode_symb($mapname,	$hash{declutter($url)}=&encode_symb($mapname,
Line 9587 and course level	Line 9872 and course level

plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash	plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash
(rolesplain.tab); plain text explanation of a user role term.	(rolesplain.tab); plain text explanation of a user role term.
$type is Course (default) or Group.	$type is Course (default) or Community.
If $forcedefault evaluates to true, text returned will be default	If $forcedefault evaluates to true, text returned will be default
text for $type. Otherwise, if this is a course, the text returned	text for $type. Otherwise, if this is a course, the text returned
will be a custom name for the role (if defined in the course's	will be a custom name for the role (if defined in the course's
Line 9797 database) for a course	Line 10082 database) for a course

=item *	=item *

createcourse($udom,$description,$url) : make/modify course	createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course

	=item *

	generate_coursenum($udom) : get a unique (unused) course number in domain $udom

=back	=back

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.999
changed lines
	Added in v.1.1024