--- loncom/cgi/loncgi.pm	2008/12/25 01:51:03	1.11
+++ loncom/cgi/loncgi.pm	2018/07/04 16:58:26	1.16
@@ -1,7 +1,7 @@
 #
 # LON-CAPA helpers for cgi-bin scripts
 #
-# $Id: loncgi.pm,v 1.11 2008/12/25 01:51:03 raeburn Exp $
+# $Id: loncgi.pm,v 1.16 2018/07/04 16:58:26 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -54,8 +54,9 @@ use warnings FATAL=>'all';
 no warnings 'uninitialized';
 
 use lib '/home/httpd/lib/perl/';
-use CGI();
+use CGI qw(:standard);
 use CGI::Cookie();
+use MIME::Types();
 use Fcntl qw(:flock);
 use LONCAPA;
 use LONCAPA::Configuration();
@@ -81,8 +82,9 @@ BEGIN {
 Inputs: 1 ( optional). When called from a handler in mod_perl,
         pass in the request object.
 
-Returns: 1 if the user has a LON-CAPA cookie 0 if not.
-Loads the users environment into the %env hash if the cookie is correct.
+Returns: 1 if the user has a LON-CAPA cookie, 0 if not.
+Side effect: Loads the user's environment into the %env hash
+             if the cookie is correct.
 
 =cut
 
@@ -90,21 +92,11 @@ Loads the users environment into the %en
 #############################################
 sub check_cookie_and_load_env {
     my ($r) = @_;
-    my %cookies;
-    if (ref($r)) {
-        %cookies = CGI::Cookie->fetch($r);    
-    } else {
-        %cookies = CGI::Cookie->fetch();
-    }
-    if (exists($cookies{'lonID'}) && 
-        -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
-        # cookie found
-        &transfer_profile_to_env($cookies{'lonID'}->value);
-        return 1;
-    } else {
-        # No cookie found
-        return 0;
+    my ($hascookie,$handle) = &check_cookie($r);
+    if (($hascookie) && ($handle)) {
+        &transfer_profile_to_env($handle);
     }
+    return $hascookie;
 }
 
 #############################################
@@ -116,6 +108,11 @@ sub check_cookie_and_load_env {
 
 Inputs: none
 
+Array context:
+Returns: (1,$handle) if the user has a LON-CAPA cookie;
+(0) if user does not have a LON-CAPA cookie.
+
+Scalar context:
 Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
 
 =cut
@@ -123,13 +120,52 @@ Returns: 1 if the user has a LON-CAPA co
 #############################################
 #############################################
 sub check_cookie {
-    my %cookies=fetch CGI::Cookie;
-    if (exists($cookies{'lonID'}) && 
-        -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
-        # cookie found
-        return 1;
+    my ($r) = @_;
+    my %cookies;
+    if (ref($r)) {
+        %cookies = CGI::Cookie->fetch($r);
+    } else {
+        %cookies = CGI::Cookie->fetch();
+    }
+    if (keys(%cookies)) {
+        my $name = 'lonID';
+        my $secure = 'lonSID';
+        my $linkname = 'lonLinkID';
+        my $pubname = 'lonPubID';
+        my $lonid;
+        if (exists($cookies{$secure})) {
+            $lonid=$cookies{$secure};
+        } elsif (exists($cookies{$name})) {
+            $lonid=$cookies{$name};
+        } elsif (exists($cookies{$linkname})) {
+            $lonid=$cookies{$linkname};
+        } elsif (exists($cookies{$pubname})) {
+            $lonid=$cookies{$pubname};
+        }
+        if ($lonid) {
+            my $handle=&LONCAPA::clean_handle($lonid->value);
+            if ($handle) {
+                if (-l "$lonidsdir/$handle.id") {
+                    my $link = readlink("$lonidsdir/$handle.id");
+                    if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
+                        $handle = $1;
+                    }
+                }
+                if (-e "$lonidsdir/".$handle.".id") {
+                    # valid cookie found
+                    if (wantarray) {
+                        return (1,$handle);
+                    } else {
+                        return 1;
+                    }
+                }
+            }
+        }
+    }
+    # No valid cookie found
+    if (wantarray) {
+        return (0);
     } else {
-        # No cookie found
         return 0;
     }
 }
@@ -153,7 +189,7 @@ Returns: undef
 #############################################
 sub transfer_profile_to_env {
     my ($handle)=@_;
-   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
+    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
 	    0640)) {
 	%Apache::lonnet::env = %disk_env;
 	untie(%disk_env);
@@ -199,7 +235,9 @@ END
 
 =cgi_getitems()
 
-Inputs: $query (the CGI query string), and $getitems, a reference to a hash 
+Inputs: $query - the CGI query string (required)
+        $getitems - reference to a hash (required)
+        $possname - permitted names of keys (optional)
 
 Returns: nothing
 
@@ -212,16 +250,55 @@ Side Effects: populates $getitems hash r
 #############################################
 #############################################
 sub cgi_getitems {
-    my ($query,$getitems)= @_;
+    my ($query,$getitems,$possnames)= @_;
     foreach (split(/&/,$query)) {
         my ($name, $value) = split(/=/,$_);
         $name = &unescape($name);
+        if (ref($possnames) eq 'ARRAY') {
+            next unless (grep(/^\Q$name\E$/,@{$possnames}));
+        }
         $value =~ tr/+/ /;
         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
         push(@{$$getitems{$name}},$value);
     }
     return;
 }
+
+#############################################
+#############################################
+
+=pod
+
+=cgi_header()
+
+Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
+        $nocache     - Boolean 1 = nocache
+Returns: HTTP Response headers constructed using CGI.pm
+
+=cut
+
+#############################################
+#############################################
+sub cgi_header {
+    my ($contenttype,$nocache) = @_;
+    my $mimetypes = MIME::Types->new;
+    my %headers;
+    if ($contenttype ne '') {
+        if ($mimetypes->type($contenttype) ne '') {
+            $headers{'-type'} = $contenttype;
+            if ($contenttype =~ m{^text/}) {
+                $headers{'-charset'} = 'utf-8';
+            }
+        }
+    }
+    if ($nocache) {
+       $headers{'-expires'} = 'now';
+    }
+    if (%headers) {
+        return CGI::header(%headers);
+    }
+    return;
+}
 
 =pod