--- loncom/lonnet/perl/lonnet.pm	2008/04/21 15:58:12	1.956
+++ loncom/lonnet/perl/lonnet.pm	2008/09/01 17:58:30	1.966
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.956 2008/04/21 15:58:12 raeburn Exp $
+# $Id: lonnet.pm,v 1.966 2008/09/01 17:58:30 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -39,7 +39,7 @@ use vars qw(%perlvar %spareid %pr %prp $
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,
     %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
-    %courseownerbuf, %coursetypebuf);
+    %courseownerbuf, %coursetypebuf,$locknum);
 
 use IO::Socket;
 use GDBM_File;
@@ -88,24 +88,26 @@ delayed.
 {
     my $logid;
     sub instructor_log {
-	my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
+	my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
+        if (($cnum eq '') || ($cdom eq '')) {
+            $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+            $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+        }
 	$logid++;
-	my $id=time().'00000'.$$.'00000'.$logid;
+        my $now = time();
+	my $id=$now.'00000'.$$.'00000'.$logid;
 	return &Apache::lonnet::put('nohist_'.$hash_name,
 				    { $id => {
 					'exe_uname' => $env{'user.name'},
 					'exe_udom'  => $env{'user.domain'},
-					'exe_time'  => time(),
+					'exe_time'  => $now,
 					'exe_ip'    => $ENV{'REMOTE_ADDR'},
 					'delflag'   => $delflag,
 					'logentry'  => $storehash,
 					'uname'     => $uname,
 					'udom'      => $udom,
 				    }
-				  },
-				    $env{'course.'.$env{'request.course.id'}.'.domain'},
-				    $env{'course.'.$env{'request.course.id'}.'.num'}
-				    );
+				  },$cdom,$cnum);
     }
 }
 
@@ -524,6 +526,51 @@ sub get_env_multiple {
     return(@values);
 }
 
+# ------------------------------------------------------------------- Locking
+
+sub set_lock {
+    my ($text)=@_;
+    $locknum++;
+    my $id=$$.'-'.$locknum;
+    &appenv({'session.locks' => $env{'session.locks'}.','.$id,
+             'session.lock.'.$id => $text});
+    return $id;
+}
+
+sub get_locks {
+    my $num=0;
+    my %texts=();
+    foreach my $lock (split(/\,/,$env{'session.locks'})) {
+       if ($lock=~/\w/) {
+          $num++;
+          $texts{$lock}=$env{'session.lock.'.$lock};
+       }
+   }
+   return ($num,%texts);
+}
+
+sub remove_lock {
+    my ($id)=@_;
+    my $newlocks='';
+    foreach my $lock (split(/\,/,$env{'session.locks'})) {
+       if (($lock=~/\w/) && ($lock ne $id)) {
+          $newlocks.=','.$lock;
+       }
+    }
+    &appenv({'session.locks' => $newlocks});
+    &delenv('session.lock.'.$id);
+}
+
+sub remove_all_locks {
+    my $activelocks=$env{'session.locks'};
+    foreach my $lock (split(/\,/,$env{'session.locks'})) {
+       if ($lock=~/\w/) {
+          &remove_lock($lock);
+       }
+    }
+}
+
+
 # ------------------------------------------ Find out current server userload
 sub userload {
     my $numusers=0;
@@ -911,6 +958,10 @@ sub retrieve_inst_usertypes {
     if (defined(&domain($udom,'primary'))) {
         my $uhome=&domain($udom,'primary');
         my $rep=&reply("inst_usertypes:$udom",$uhome);
+        if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
+            &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
+            return (\%returnhash,\@order);
+        }
         my ($hashitems,$orderitems) = split(/:/,$rep); 
         my @pairs=split(/\&/,$hashitems);
         foreach my $item (@pairs) {
@@ -1839,7 +1890,7 @@ sub process_coursefile {
             print $fh $env{'form.'.$source};
             close($fh);
             if ($parser eq 'parse') {
-                my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
+                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);
                 }
@@ -2047,7 +2098,7 @@ sub finishuserfileupload {
 	close(FH);
     }
     if ($parser eq 'parse') {
-        my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
+        my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
 						   $codebase);
         unless ($parse_result eq 'ok') {
             &logthis('Failed to parse '.$filepath.$file.
@@ -2087,7 +2138,7 @@ sub finishuserfileupload {
 }
 
 sub extract_embedded_items {
-    my ($filepath,$file,$allfiles,$codebase,$content) = @_;
+    my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();
     my %javafiles = (
                       codebase => '',
@@ -2102,7 +2153,7 @@ sub extract_embedded_items {
     if ($content) {
         $p = HTML::LCParser->new($content);
     } else {
-        $p = HTML::LCParser->new($filepath.'/'.$file);
+        $p = HTML::LCParser->new($fullpath);
     }
     while (my $t=$p->get_token()) {
 	if ($t->[0] eq 'S') {
@@ -2480,6 +2531,36 @@ sub userrolelog {
     }
 }
 
+sub courserolelog {
+    my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
+    if (($trole eq 'cc') || ($trole eq 'in') ||
+        ($trole eq 'ep') || ($trole eq 'ad') ||
+        ($trole eq 'ta') || ($trole eq 'st') ||
+        ($trole=~/^cr/) || ($trole eq 'gr')) {
+        if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
+            my $cdom = $1;
+            my $cnum = $2;
+            my $sec = $3;
+            my $namespace = 'rolelog';
+            my %storehash = (
+                               role    => $trole,
+                               start   => $tstart,
+                               end     => $tend,
+                               selfenroll => $selfenroll,
+                               context    => $context,
+                            );
+            if ($trole eq 'gr') {
+                $namespace = 'groupslog';
+                $storehash{'group'} = $sec;
+            } else {
+                $storehash{'section'} = $sec;
+            }
+            &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
+        }
+    }
+    return;
+}
+
 sub get_course_adv_roles {
     my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));
@@ -2685,7 +2766,7 @@ sub courseidput {
 sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
-        $selfenrollonly)=@_;
+        $selfenrollonly,$catfilter,$showhidden,$caller)=@_;
     my $as_hash = 1;
     my %returnhash;
     if (!$domfilter) { $domfilter=''; }
@@ -2703,7 +2784,8 @@ sub courseiddump {
                          &escape($instcodefilter).':'.&escape($ownerfilter).
                          ':'.&escape($coursefilter).':'.&escape($typefilter).
                          ':'.&escape($regexp_ok).':'.$as_hash.':'.
-                         &escape($selfenrollonly),$tryserver);
+                         &escape($selfenrollonly).':'.&escape($catfilter).':'.
+                         $showhidden.':'.$caller,$tryserver);
                 my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);
@@ -3479,12 +3561,13 @@ sub privileged {
 
 sub rolesinit {
     my ($domain,$username,$authhost)=@_;
+    my %userroles;
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
-    if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
+    if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; }
     my %allroles=();
     my %allgroups=();   
     my $now=time;
-    my %userroles = ('user.login.time' => $now);
+    %userroles = ('user.login.time' => $now);
     my $group_privs;
 
     if ($rolesdump ne '') {
@@ -4457,7 +4540,6 @@ sub allowed {
     }
     
 # Full access at system, domain or course-wide level? Exit.
-
     if ($thisallowed=~/F/) {
 	return 'F';
     }
@@ -5236,11 +5318,11 @@ sub toggle_coursegroup_status {
 }
 
 sub modify_group_roles {
-    my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
+    my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
     my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);
-    my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+    my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
     if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }
@@ -5356,7 +5438,8 @@ sub plaintext {
 # ----------------------------------------------------------------- Assign Role
 
 sub assignrole {
-    my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_;
+    my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
+        $context)=@_;
     my $mrole;
     if ($role =~ /^cr\//) {
         my $cwosec=$url;
@@ -5415,6 +5498,7 @@ sub assignrole {
     }
     my $origstart = $start;
     my $origend = $end;
+    my $delflag;
 # actually delete
     if ($deleteflag) {
 	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
@@ -5425,6 +5509,7 @@ sub assignrole {
 # set start and finish to negative values for userrolelog
            $start=-1;
            $end=-1;
+           $delflag = 1;
         }
     }
 # send command
@@ -5433,9 +5518,10 @@ sub assignrole {
     if ($answer eq 'ok') {
 	&userrolelog($role,$uname,$udom,$url,$start,$end);
 # for course roles, perform group memberships changes triggered by role change.
+        &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
         unless ($role =~ /^gr/) {
             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
-                                             $origstart);
+                                             $origstart,$selfenroll,$context);
         }
     }
     return $answer;
@@ -5473,7 +5559,7 @@ sub modifyuser {
     my ($udom,    $uname, $uid,
         $umode,   $upass, $first,
         $middle,  $last,  $gene,
-        $forceid, $desiredhome, $email)=@_;
+        $forceid, $desiredhome, $email, $inststatus)=@_;
     $udom= &LONCAPA::clean_domain($udom);
     $uname=&LONCAPA::clean_username($uname);
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
@@ -5534,7 +5620,7 @@ sub modifyuser {
 # -------------------------------------------------------------- Add names, etc
     my @tmp=&get('environment',
 		   ['firstname','middlename','lastname','generation','id',
-                    'permanentemail'],
+                    'permanentemail','inststatus'],
 		   $udom,$uname);
     my %names;
     if ($tmp[0] =~ m/^error:.*/) { 
@@ -5552,19 +5638,23 @@ sub modifyuser {
     if (defined($gene))   { $names{'generation'} = $gene; }
     if ($email) {
        $email=~s/[^\w\@\.\-\,]//gs;
-       if ($email=~/\@/) { $names{'notification'} = $email;
-			   $names{'critnotification'} = $email;
-			   $names{'permanentemail'} = $email; }
+       if ($email=~/\@/) { $names{'permanentemail'} = $email; }
     }
     if ($uid) { $names{'id'}  = $uid; }
+    if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } 
     my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }
     my $sqlresult = &update_allusers_table($uname,$udom,\%names);
     &devalidate_cache_new('namescache',$uname.':'.$udom);
-    &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
-             $umode.', '.$first.', '.$middle.', '.
-	     $last.', '.$gene.' by '.
-             $env{'user.name'}.' at '.$env{'user.domain'});
+    my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
+                 $umode.', '.$first.', '.$middle.', '.
+	         $last.', '.$gene.', '.$email.', '.$inststatus;
+    if ($env{'user.name'} ne '' && $env{'user.domain'}) {
+        $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
+    } else {
+        $logmsg .= ' during self creation';
+    }
+    &logthis($logmsg);
     return 'ok';
 }
 
@@ -5572,7 +5662,8 @@ sub modifyuser {
 
 sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
-        $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
+        $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
+        $selfenroll,$context)=@_;
     if (!$cid) {
 	unless ($cid=$env{'request.course.id'}) {
 	    return 'not_in_class';
@@ -5587,12 +5678,12 @@ sub modifystudent {
     # students environment
     $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
-					$gene,$usec,$end,$start,$type,$locktype,$cid);
+					$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
     return $reply;
 }
 
 sub modify_student_enrollment {
-    my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll) = @_;
+    my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
     my ($cdom,$cnum,$chome);
     if (!$cid) {
 	unless ($cid=$env{'request.course.id'}) {
@@ -5650,7 +5741,7 @@ sub modify_student_enrollment {
     if ($usec) {
 	$uurl.='/'.$usec;
     }
-    return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll);
+    return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
 }
 
 sub format_name {
@@ -5779,26 +5870,26 @@ sub is_course {
 # ---------------------------------------------------------- Assign Custom Role
 
 sub assigncustomrole {
-    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
-                       $end,$start,$deleteflag);
+                       $end,$start,$deleteflag,$selfenroll,$context);
 }
 
 # ----------------------------------------------------------------- Revoke Role
 
 sub revokerole {
-    my ($udom,$uname,$url,$role,$deleteflag)=@_;
+    my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;
-    return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
+    return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
 }
 
 # ---------------------------------------------------------- Revoke Custom Role
 
 sub revokecustomrole {
-    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
+    my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;
     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
-           $deleteflag);
+           $deleteflag,$selfenroll,$context);
 }
 
 # ------------------------------------------------------------ Disk usage
@@ -8726,6 +8817,7 @@ $memcache=new Cache::Memcached({'servers
 
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;
+$locknum=0;
 
 &logtouch();
 &logthis('<font color="yellow">INFO: Read configuration</font>');
@@ -9043,7 +9135,7 @@ provided for types, will default to retu
 
 =item *
 
-assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
+assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
 user for the level given by URL.  Optional start and end dates (leave empty
 string or zero for "no date")
 
@@ -9060,14 +9152,15 @@ modifyuserauth($udom,$uname,$umode,$upas
 
 =item *
 
-modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 
+modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
+           $forceid,$desiredhome,$email,$inststatus) : 
 modify user
 
 =item *
 
 modifystudent
 
-modify a students enrollment and identification information.
+modify a student's enrollment and identification information.
 The course id is resolved based on the current users environment.  
 This means the envoking user must be a course coordinator or otherwise
 associated with a course.
@@ -9079,25 +9172,25 @@ Inputs:
 
 =over 4
 
-=item B<$udom> Students loncapa domain
+=item B<$udom> Student's loncapa domain
 
-=item B<$uname> Students loncapa login name
+=item B<$uname> Student's loncapa login name
 
-=item B<$uid> Students id/student number
+=item B<$uid> Student/Employee ID
 
-=item B<$umode> Students authentication mode
+=item B<$umode> Student's authentication mode
 
-=item B<$upass> Students password
+=item B<$upass> Student's password
 
-=item B<$first> Students first name
+=item B<$first> Student's first name
 
-=item B<$middle> Students middle name
+=item B<$middle> Student's middle name
 
-=item B<$last> Students last name
+=item B<$last> Student's last name
 
-=item B<$gene> Students generation
+=item B<$gene> Student's generation
 
-=item B<$usec> Students section in course
+=item B<$usec> Student's section in course
 
 =item B<$end> Unix time of the roles expiration
 
@@ -9107,6 +9200,20 @@ Inputs:
 
 =item B<$desiredhome> server to use as home server for student
 
+=item B<$email> Student's permanent e-mail address
+
+=item B<$type> Type of enrollment (auto or manual)
+
+=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto    
+
+=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
+
+=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
+
+=item B<$context> role change context (shown in User Management Logs display in a course)
+
+=item B<$inststatus> institutional status of user - : separated string of escaped status types  
+
 =back
 
 =item *
@@ -9140,6 +9247,16 @@ Inputs:
 
 =item $start
 
+=item $type
+
+=item $locktype
+
+=item $cid
+
+=item $selfenroll
+
+=item $context
+
 =back