[LON-CAPA-cvs] cvs: loncom /interface loncommon.pm /lonnet/perl lonnet.pm

[raeburn]

raeburn		Sun Feb 23 20:53:03 2014 EDT

  Modified files:              
    /loncom/interface	loncommon.pm 
    /loncom/lonnet/perl	lonnet.pm 
  Log:
  - Changes to regexps to support adhoc role switching to a custom role
    in a course, created by a user with an e-mail address as username.
  
  
Index: loncom/interface/loncommon.pm
diff -u loncom/interface/loncommon.pm:1.1177 loncom/interface/loncommon.pm:1.1178
--- loncom/interface/loncommon.pm:1.1177	Thu Feb 20 00:56:15 2014
+++ loncom/interface/loncommon.pm	Sun Feb 23 20:52:58 2014
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # a pile of common routines
 #
-# $Id: loncommon.pm,v 1.1177 2014/02/20 00:56:15 raeburn Exp $
+# $Id: loncommon.pm,v 1.1178 2014/02/23 20:52:58 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -5151,7 +5151,10 @@
     @design{keys(%$addentries)} = @$addentries{keys(%$addentries)}; 
 
  # role and realm
-    my ($role,$realm) = split(/\./,$env{'request.role'},2);
+    my ($role,$realm) = split(m{\./},$env{'request.role'},2);
+    if ($realm) {
+        $realm = '/'.$realm;
+    }
     if ($role  eq 'ca') {
         my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
         $realm = &plainname($rname,$rdom);
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1249 loncom/lonnet/perl/lonnet.pm:1.1250
--- loncom/lonnet/perl/lonnet.pm:1.1249	Sun Jan  5 11:43:58 2014
+++ loncom/lonnet/perl/lonnet.pm	Sun Feb 23 20:53:03 2014
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1249 2014/01/05 11:43:58 raeburn Exp $
+# $Id: lonnet.pm,v 1.1250 2014/02/23 20:53:03 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -676,7 +676,7 @@
 	    if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 $refused = 1;
                 if (ref($roles) eq 'ARRAY') {
-                    my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
+                    my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});
                     if (grep(/^\Q$role\E$/,@{$roles})) {
                         $refused = 0;
                     }
@@ -5214,7 +5214,7 @@
 sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
-    my $homsvr=homeserver($rauthor,$rdomain);
+    my $homsvr = &homeserver($rauthor,$rdomain);
     if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
@@ -5335,11 +5335,11 @@
 
 sub role_status {
     my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
-    my @pwhere = ();
     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
-        (undef,undef,$$role, at pwhere)=split(/\./,$rolekey);
+        my ($one,$two) = split(m{\./},$rolekey,2);
+        (undef,undef,$$role) = split(/\./,$one,3);
+        $$where = '/'.$two;
         unless (!defined($$role) || $$role eq '') {
-            $$where=join('.', at pwhere);
             $$trolecode=$$role.'.'.$$where;
             ($$tstart,$$tend)=split(/\./,$env{$rolekey});
             $$tstatus='is';
@@ -6736,7 +6736,7 @@
 	&& &is_portfolio_url($uri)) {
 	$thisallowed = &portfolio_access($uri);
     }
-    
+
 # Full access at system, domain or course-wide level? Exit.
     if ($thisallowed=~/F/) {
 	return 'F';