version 1.206, 2002/04/04 20:06:20
|
version 1.211, 2002/05/06 13:46:41
|
Line 84 qw(%perlvar %hostname %homecache %hostip
|
Line 84 qw(%perlvar %hostname %homecache %hostip
|
use IO::Socket; |
use IO::Socket; |
use GDBM_File; |
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
use HTML::TokeParser; |
use HTML::LCParser; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
my $readit; |
my $readit; |
|
|
Line 1877 sub modifyuser {
|
Line 1877 sub modifyuser {
|
# ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
if (($uhome eq 'no_host') && ($umode) && ($upass)) { |
my $unhome=''; |
my $unhome=''; |
if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { |
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
$unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
|
} elsif (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
|
$unhome = $desiredhome; |
$unhome = $desiredhome; |
} else { |
} elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { |
|
$unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
|
} else { # load balancing routine for determining $unhome |
my $tryserver; |
my $tryserver; |
my $loadm=10000000; |
my $loadm=10000000; |
foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
Line 1907 sub modifyuser {
|
Line 1907 sub modifyuser {
|
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { |
return 'error: verify home'; |
return 'error: verify home'; |
} |
} |
} |
} # End of creation of new user |
# ---------------------------------------------------------------------- Add ID |
# ---------------------------------------------------------------------- Add ID |
if ($uid) { |
if ($uid) { |
$uid=~tr/A-Z/a-z/; |
$uid=~tr/A-Z/a-z/; |
Line 1925 sub modifyuser {
|
Line 1925 sub modifyuser {
|
my %names=&get('environment', |
my %names=&get('environment', |
['firstname','middlename','lastname','generation'], |
['firstname','middlename','lastname','generation'], |
$udom,$uname); |
$udom,$uname); |
|
if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } |
if ($first) { $names{'firstname'} = $first; } |
if ($first) { $names{'firstname'} = $first; } |
if ($middle) { $names{'middlename'} = $middle; } |
if ($middle) { $names{'middlename'} = $middle; } |
if ($last) { $names{'lastname'} = $last; } |
if ($last) { $names{'lastname'} = $last; } |
Line 1942 sub modifyuser {
|
Line 1943 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)=@_; |
$end,$start,$forceid,$desiredhome)=@_; |
my $cid=''; |
my $cid=''; |
unless ($cid=$ENV{'request.course.id'}) { |
unless ($cid=$ENV{'request.course.id'}) { |
return 'not_in_class'; |
return 'not_in_class'; |
} |
} |
# --------------------------------------------------------------- Make the user |
# --------------------------------------------------------------- Make the user |
my $reply=&modifyuser |
my $reply=&modifyuser |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid); |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
|
$desiredhome); |
unless ($reply eq 'ok') { return $reply; } |
unless ($reply eq 'ok') { return $reply; } |
my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
Line 2388 sub metadata {
|
Line 2390 sub metadata {
|
my %metathesekeys=(); |
my %metathesekeys=(); |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); |
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); |
my $parser=HTML::TokeParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
my $token; |
my $token; |
undef %metathesekeys; |
undef %metathesekeys; |
while ($token=$parser->get_token) { |
while ($token=$parser->get_token) { |
Line 2477 sub metadata {
|
Line 2479 sub metadata {
|
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
} |
} |
unless ( |
unless ( |
$metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) |
$metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) |
) { $metacache{$uri.':'.$unikey}= |
) { $metacache{$uri.':'.$unikey}= |
$metacache{$uri.':'.$unikey.'.default'}; |
$metacache{$uri.':'.$unikey.'.default'}; |
} |
} |
Line 2515 sub symblist {
|
Line 2517 sub symblist {
|
return 'error'; |
return 'error'; |
} |
} |
|
|
|
# --------------------------------------------------------------- Clean-up symb |
|
|
|
sub symbclean { |
|
my $symb=shift; |
|
# remove version from map |
|
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; |
|
# remove version from URL |
|
$symb=~s/\.(\d+)\.(\w+)$/\.$2/; |
|
return $symb; |
|
} |
|
|
# ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
|
|
sub symbread { |
sub symbread { |
my $thisfn=shift; |
my $thisfn=shift; |
unless ($thisfn) { |
unless ($thisfn) { |
if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; } |
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } |
$thisfn=$ENV{'request.filename'}; |
$thisfn=$ENV{'request.filename'}; |
} |
} |
$thisfn=declutter($thisfn); |
$thisfn=declutter($thisfn); |
Line 2579 sub symbread {
|
Line 2592 sub symbread {
|
} |
} |
} |
} |
if ($syval) { |
if ($syval) { |
return $syval.'___'.$thisfn; |
return &symbclean($syval.'___'.$thisfn); |
} |
} |
} |
} |
&appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |