--- loncom/lonnet/perl/lonnet.pm 2006/11/29 07:46:40 1.810 +++ loncom/lonnet/perl/lonnet.pm 2007/04/24 19:38:15 1.824.2.4 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.810 2006/11/29 07:46:40 raeburn Exp $ +# $Id: lonnet.pm,v 1.824.2.4 2007/04/24 19:38:15 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -53,7 +53,6 @@ use Time::HiRes qw( gettimeofday tv_inte use Cache::Memcached; use Digest::MD5; use Math::Random; -use lib '/home/httpd/lib/perl'; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; @@ -368,6 +367,26 @@ sub transfer_profile_to_env { } } +sub timed_flock { + my ($file,$lock_type) = @_; + my $failed=0; + eval { + local $SIG{__DIE__}='DEFAULT'; + local $SIG{ALRM}=sub { + $failed=1; + die("failed lock"); + }; + alarm(13); + flock($file,$lock_type); + alarm(0); + }; + if ($failed) { + return undef; + } else { + return 1; + } +} + # ---------------------------------------------------------- Append Environment sub appenv { @@ -382,8 +401,11 @@ sub appenv { $env{$key}=$newenv{$key}; } } - if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), - 0640)) { + open(my $env_file,$env{'user.environment'}); + if (&timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { while (my ($key,$value) = each(%newenv)) { $disk_env{$key} = $value; } @@ -400,8 +422,11 @@ sub delenv { "Attempt to delete from environment ".$delthis); return 'error'; } - if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), - 0640)) { + open(my $env_file,$env{'user.environment'}); + if (&timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { foreach my $key (keys(%disk_env)) { if ($key=~/^$delthis/) { delete($env{$key}); @@ -878,6 +903,25 @@ sub devalidate_getsection_cache { &devalidate_cache_new('getsection',$hashid); } +sub courseid_to_courseurl { + my ($courseid) = @_; + #already url style courseid + return $courseid if ($courseid =~ m{^/}); + + if (exists($env{'course.'.$courseid.'.num'})) { + my $cnum = $env{'course.'.$courseid.'.num'}; + my $cdom = $env{'course.'.$courseid.'.domain'}; + return "/$cdom/$cnum"; + } + + my %courseinfo=&Apache::lonnet::coursedescription($courseid); + if (exists($courseinfo{'num'})) { + return "/$courseinfo{'domain'}/$courseinfo{'num'}"; + } + + return undef; +} + sub getsection { my ($udom,$unam,$courseid)=@_; my $cachetime=1800; @@ -901,14 +945,13 @@ sub getsection { # If there is more than one expired role, choose the one which ended last. # If there is a role which has expired, return it. # - foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$line,2); - $key=&unescape($key); + $courseid = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$unam,$courseid); + foreach my $key (keys(%roleshash)) { next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; if ($key eq $courseid.'_st') { $section=''; } - my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key})); my $now=time; if (defined($end) && $end && ($now > $end)) { $Expired{$end}=$section; @@ -947,10 +990,16 @@ my %remembered; my %accessed; my $kicks=0; my $hits=0; +sub make_key { + my ($name,$id) = @_; + if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); } + return &escape($name.':'.$id); +} + sub devalidate_cache_new { my ($name,$id,$debug) = @_; if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); $memcache->delete($id); delete($remembered{$id}); delete($accessed{$id}); @@ -958,7 +1007,7 @@ sub devalidate_cache_new { sub is_cached_new { my ($name,$id,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); if (exists($remembered{$id})) { if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } $accessed{$id}=[&gettimeofday()]; @@ -981,7 +1030,7 @@ sub is_cached_new { sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); my $setvalue=$value; if (!defined($setvalue)) { $setvalue='__undef__'; @@ -1684,6 +1733,12 @@ sub removeuserfile { if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { my $metafile = $fname.'.meta'; my $metaresult = &removeuserfile($docuname,$docudom,$metafile); + my $url = "/uploaded/$docudom/$docuname/$fname"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my $sqlresult = + &update_portfolio_table($docuname,$docudom,$file, + 'portfolio_metadata',$group, + 'delete'); } } return $result; @@ -1706,6 +1761,12 @@ sub renameuserfile { my $newmeta = $new.'.meta'; my $metaresult = &renameuserfile($docuname,$docudom,$oldmeta,$newmeta); + my $url = "/uploaded/$docudom/$docuname/$old"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my $sqlresult = + &update_portfolio_table($docuname,$docudom,$file, + 'portfolio_metadata',$group, + 'delete'); } } return $result; @@ -1772,7 +1833,7 @@ sub flushcourselogs { if ($entry =~ /___count$/) { my ($dom,$name); ($dom,$name,undef)= - ($entry=~m{___($match_domain)/($match_username)/(.*)___count$}); + ($entry=~m{___($match_domain)/($match_name)/(.*)___count$}); if (! defined($dom) || $dom eq '' || ! defined($name) || $name eq '') { my $cid = $env{'request.course.id'}; @@ -1793,7 +1854,7 @@ sub flushcourselogs { } } } else { - my ($dom,$name) = ($entry=~m{___($match_domain)/($match_username)/(.*)___(\w+)$}); + my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); my %temphash=($entry => $accesshash{$entry}); if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { delete $accesshash{$entry}; @@ -2732,6 +2793,7 @@ sub coursedescription { if (!$args->{'one_time'}) { $envhash{'course.'.$normalid.'.last_cache'}=time; } + if ($chome ne 'no_host') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { @@ -2887,7 +2949,7 @@ sub group_roleprivs { if (($tend!=0) && ($tend<$now)) { $access = 0; } if (($tstart!=0) && ($tstart>$now)) { $access=0; } if ($access) { - my ($course,$group) = ($area =~ m|(/$match_domain/$match_username)/([^/]+)$|); + my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|); $$allgroups{$course}{$group} .=':'.$group_privs; } } @@ -2918,7 +2980,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { my ($trole,$area,$sec,$extendedarea); - if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_username)(/?\w*)-) { + if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) { $trole = $1; $area = $2; $sec = $3; @@ -3030,7 +3092,23 @@ sub dump { sub dumpstore { my ($namespace,$udomain,$uname,$regexp,$range)=@_; - return &dump($namespace,$udomain,$uname,$regexp,$range); + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; + } + my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + return %returnhash; } # -------------------------------------------------------------- keys interface @@ -3043,6 +3121,7 @@ sub getkeys { my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); my @keyarray=(); foreach my $key (split(/\&/,$rep)) { + next if ($key =~ /^error: 2 /); push(@keyarray,&unescape($key)); } return @keyarray; @@ -3063,7 +3142,7 @@ sub currentdump { if ($rep eq "unknown_cmd") { # an old lond will not know currentdump # Do a dump and make it look like a currentdump - my @tmp = &dump($courseid,$sdom,$sname,'.'); + my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); return if ($tmp[0] =~ /^(error:|no_such_host)/); my %hash = @tmp; @tmp=(); @@ -3088,6 +3167,8 @@ sub convert_dump_to_currentdump{ # we might run in to problems with parameter names =~ /^v\./ while (my ($key,$value) = each(%hash)) { my ($v,$symb,$param) = split(/:/,$key); + $symb = &unescape($symb); + $param = &unescape($param); next if ($v eq 'version' || $symb eq 'keys'); next if (exists($returnhash{$symb}) && exists($returnhash{$symb}->{$param}) && @@ -3301,6 +3382,22 @@ sub portfolio_access { my ($requrl) = @_; my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); my $result = &get_portfolio_access($udom,$unum,$file_name,$group); + if ($result) { + my %setters; + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom); + if ($startblock && $endblock) { + return 'B'; + } + } else { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; + } + } + } if ($result eq 'ok') { return 'F'; } elsif ($result =~ /^[^:]+:guest_/) { @@ -3364,9 +3461,16 @@ sub get_portfolio_access { } if (@users > 0) { foreach my $userkey (@users) { - if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { - return 'ok'; - } + if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { + foreach my $item (@{$access_hash->{$userkey}{'users'}}) { + if (ref($item) eq 'HASH') { + if (($item->{'uname'} eq $env{'user.name'}) && + ($item->{'udom'} eq $env{'user.domain'})) { + return 'ok'; + } + } + } + } } } my %roleshash; @@ -3376,7 +3480,7 @@ sub get_portfolio_access { my (%allgroups,%allroles); my ($start,$end,$role,$sec,$group); foreach my $envkey (%env) { - if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_username)/?([^/]*)$-) { + if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { my $cid = $2.'_'.$3; if ($1 eq 'gr') { $group = $4; @@ -3389,7 +3493,7 @@ sub get_portfolio_access { } $allroles{$cid}{$1}{$sec} = $env{$envkey}; } - } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_username)/?([^/]*)$-) { + } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) { my $cid = $2.'_'.$3; if ($4 eq '') { $sec = 'none'; @@ -3484,12 +3588,12 @@ sub parse_portfolio_url { my ($type,$udom,$unum,$group,$file_name); - if ($url =~ m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) { + if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) { $type = 1; $udom = $1; $unum = $2; $file_name = $3; - } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_username)/groups/([^/]+)/portfolio/(.+)$-) { + } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) { $type = 2; $udom = $1; $unum = $2; @@ -3509,7 +3613,7 @@ sub is_portfolio_url { sub is_portfolio_file { my ($file) = @_; - if (($file =~ /^portfolio/) || ($file =~ /^groups\/$match_username\/portfolio/)) { + if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) { return 1; } return; @@ -3521,7 +3625,7 @@ sub is_portfolio_file { sub customaccess { my ($priv,$uri)=@_; my ($urole,$urealm)=split(/\./,$env{'request.role'},2); - my ($udom,$ucrs,$usec)=split(/\//,$urealm); + my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm); $udom = &LONCAPA::clean_domain($udom); $ucrs = &LONCAPA::clean_username($ucrs); my $access=0; @@ -3581,7 +3685,14 @@ sub allowed { my ($space,$domain,$name,@dir)=split('/',$uri); if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { - return 'F'; + my %setters; + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; + } else { + return 'F'; + } } # bre access to group portfolio for rgf priv in group, or mdg or vcg in course. @@ -3857,6 +3968,8 @@ sub allowed { unless ($env{'request.course.id'}) { if ($thisallowed eq 'A') { return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; } else { return '1'; } @@ -3924,6 +4037,8 @@ sub allowed { if ($thisallowed eq 'A') { return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; } return 'F'; } @@ -4050,6 +4165,18 @@ sub log_query { return get_query_reply($queryid); } +# -------------------------- Update MySQL table for portfolio file + +sub update_portfolio_table { + my ($uname,$udom,$file_name,$query,$group,$action) = @_; + my $homeserver = &homeserver($uname,$udom); + my $queryid= + &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). + ':'.&escape($file_name).':'.$action,$homeserver); + my $reply = &get_query_reply($queryid); + return $reply; +} + # ------- Request retrieval of institutional classlists for course(s) sub fetch_enrollment_query { @@ -4437,7 +4564,7 @@ sub get_active_groups { my $now = time; my %groups = (); foreach my $key (keys(%env)) { - if ($key =~ m-user\.role\.gr\./($match_domain)/($match_username)/(\w+)$-) { + if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) { my ($start,$end) = split(/\./,$env{$key}); if (($end!=0) && ($end<$now)) { next; } if (($start!=0) && ($start>$now)) { next; } @@ -4465,38 +4592,34 @@ sub get_users_groups { @usersgroups = split(/:/,$grouplist); } else { $grouplist = ''; - my %roleshash = &dump('roles',$udom,$uname,$courseid); - my ($tmp) = keys(%roleshash); - if ($tmp=~/^error:/) { - &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); - } else { - my $access_end = $env{'course.'.$courseid. - '.default_enrollment_end_date'}; - my $now = time; - foreach my $key (keys(%roleshash)) { - if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { - my $group = $1; - if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { - my $start = $2; - my $end = $1; - if ($start == -1) { next; } # deleted from group - if (($start!=0) && ($start>$now)) { next; } - if (($end!=0) && ($end<$now)) { - if ($access_end && $access_end < $now) { - if ($access_end - $end < 86400) { - push(@usersgroups,$group); - } + my $courseurl = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$uname,$courseurl); + my $access_end = $env{'course.'.$courseid. + '.default_enrollment_end_date'}; + my $now = time; + foreach my $key (keys(%roleshash)) { + if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) { + my $group = $1; + if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { + my $start = $2; + my $end = $1; + if ($start == -1) { next; } # deleted from group + if (($start!=0) && ($start>$now)) { next; } + if (($end!=0) && ($end<$now)) { + if ($access_end && $access_end < $now) { + if ($access_end - $end < 86400) { + push(@usersgroups,$group); } - next; } - push(@usersgroups,$group); + next; } + push(@usersgroups,$group); } } - @usersgroups = &sort_course_groups($courseid,@usersgroups); - $grouplist = join(':',@usersgroups); - &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); } + @usersgroups = &sort_course_groups($courseid,@usersgroups); + $grouplist = join(':',@usersgroups); + &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); } return @usersgroups; } @@ -4543,7 +4666,7 @@ sub assignrole { my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; - $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4553,8 +4676,7 @@ sub assignrole { $mrole='cr'; } elsif ($role =~ /^gr\//) { my $cwogrp=$url; - $cwogrp=~s{^/($match_domain)/($match_username)/.*} - {$1/$2}x; + $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2}; unless (&allowed('mdg',$cwogrp)) { &logthis('Refused group assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4564,7 +4686,7 @@ sub assignrole { $mrole='gr'; } else { my $cwosec=$url; - $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4930,6 +5052,16 @@ ENDINITMAP return '/'.$udom.'/'.$uname; } +sub is_course { + my ($cdom,$cnum) = @_; + my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, + undef,'.'); + if (exists($courses{$cdom.'_'.$cnum})) { + return 1; + } + return 0; +} + # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { @@ -5208,6 +5340,15 @@ sub modify_access_controls { # remove lock my @del_lock = ($file_name."\0".'locked_access_records'); my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); + my ($file,$group); + if (&is_course($domain,$user)) { + ($group,$file) = split(/\//,$file_name,2); + } else { + $file = $file_name; + } + my $sqlresult = + &update_portfolio_table($user,$domain,$file,'portfolio_access', + $group); } else { $outcome = "error: could not obtain lockfile\n"; } @@ -5443,7 +5584,7 @@ sub stat_file { my ($udom,$uname,$file,$dir); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = - ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_username)/?(.*)-); + ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; $dir = &propath($udom,$uname); } @@ -7008,7 +7149,7 @@ sub repcopy_userfile { if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } my ($cdom,$cnum,$filename) = - ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_username)/+(.*)|); + ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); my ($info,$rtncode); my $uri="/uploaded/$cdom/$cnum/$filename"; if (-e "$file") { @@ -7039,14 +7180,7 @@ sub repcopy_userfile { } else { my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { - my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',&tokenwrapper($uri)); - my $response=$ua->request($request); - if ($response->is_success()) { - $info=$response->content; - } else { - return -1; - } + return -1; } my @parts = ($cdom,$cnum); if ($filename =~ m|^(.+)/[^/]+$|) { @@ -7130,7 +7264,7 @@ sub filelocation { $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= - ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_username)/+(.*)$-); + ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); my $home=&homeserver($uname,$udom); my $is_me=0; my @ids=¤t_machine_ids(); @@ -7170,7 +7304,7 @@ sub hreflocation { } elsif ($file=~m-/home/($match_username)/public_html/-) { $file=~s-^/home/($match_username)/public_html/-/~$1/-; } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { - $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_username)/userfiles/ + $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ -/uploaded/$1/$2/-x; } return $file; @@ -7200,6 +7334,29 @@ sub current_machine_ids { return @ids; } +sub additional_machine_domains { + my @domains; + open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); + while( my $line = <$fh>) { + $line =~ s/\s//g; + push(@domains,$line); + } + return @domains; +} + +sub default_login_domain { + my $domain = $perlvar{'lonDefDomain'}; + my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0]; + foreach my $posdom (¤t_machine_domains(), + &additional_machine_domains()) { + if (lc($posdom) eq lc($testdomain)) { + $domain=$posdom; + last; + } + } + return $domain; +} + # ------------------------------------------------------------- Declutters URLs sub declutter {