home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / NeedSSL.pm < prev    next >
Encoding:
Perl POD Document  |  2004-04-26  |  5.3 KB  |  201 lines
  1. package CGI::NeedSSL;
  2.  
  3. use strict;
  4. use warnings;
  5. use vars qw($VERSION @EXPORT_OK @ISA);
  6. $VERSION = '0.08';
  7. use Exporter;
  8. @ISA = qw(Exporter);
  9. @EXPORT_OK = qw(croak_unless_via_SSL cgi_is_via_SSL 
  10.     croak_unless_via_ssl cgi_user_error_msg cgi_error_exit 
  11.     redirect_unless_via_HTTP redirect_unless_via_http 
  12.     redirect_unless_via_SSL redirect_unless_via_ssl);
  13. use CGI::Carp qw(croak);
  14.  
  15. =head1 NAME
  16.  
  17. CGI::NeedSSL - module to check SSL status of a CGI call.
  18.  
  19. =head1 DESCRIPTION
  20.  
  21. Though some servers are configured with a separate cgi-bin directory for 
  22. SSL-only CGI programs, many allow CGI programs to be called either via a 
  23. http:// or a https:// url.
  24.  
  25. This module allows SSL-only status of a CGI program running environment to 
  26. be checked and enforced by a perl CGI program.
  27.  
  28. =head1 SYNOPSIS
  29.  
  30. use CGI::NeedSSL qw( croak_unless_via_SSL );
  31. croak_unless_via_SSL();
  32.  
  33. =cut
  34.  
  35. my $user_msg;
  36. my $https_ahref = 'https://localhost';
  37. my $http_ahref = 'http://localhost';
  38. my $svrname = $ENV{SERVER_NAME};
  39. my $scrname = $ENV{SCRIPT_NAME};
  40. my $qstring = $ENV{QUERY_STRING};
  41. if($svrname and $scrname) {    
  42.     $https_ahref =     'https://' . $svrname . $scrname;
  43.     $https_ahref .= "?$qstring" if($qstring);
  44.     $http_ahref = $https_ahref;
  45.     $http_ahref =~ s/https/http/;
  46. }
  47.  
  48. my $header_msg = "Content-Type: text/html; charset=ISO-8859-1\n\n";
  49. my $redirect_msg = "Location: $https_ahref\n\n";
  50. my $redirect_to_http_msg = "Location: $http_ahref\n\n";
  51. my $default_msg = <<HTML_MSG;
  52. <?xml version=\"1.0\" encoding=\"utf-8\"?>
  53. <!DOCTYPE html
  54.         PUBLIC \"-//W3C//DTD XHTML Basic 1.0//EN\"
  55.         \"http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd\">
  56. <html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"en-US\">
  57. <head><title>Error: Need to use SSL (https:) to access</title></head>
  58. <body>
  59.   <h2>Sorry, this page needs to be accessed via SSL (https:).</h2>
  60. <p>Maybe you meant to try  <a href=\"$https_ahref\"> this URL: $https_ahref\</a\> instead.</p>
  61. </body>
  62. </html>
  63. HTML_MSG
  64.  
  65. =head1 METHODS
  66.  
  67. =over 4
  68.  
  69. item B<cgi_is_via_SSL>
  70.  
  71. Return 1 if https/SSL in effect, otherwise return undef.
  72.  
  73. =cut
  74.  
  75. # are we using https/ssl ?  returns 1 if so, otherwise undef
  76. # Any HTML/SSL compliant web server should manage the HTTPS environment variable
  77. sub cgi_is_via_SSL {
  78.     return 1 if $ENV{HTTPS};
  79.     return;
  80. }
  81.  
  82. =item B<croak_unless_via_SSL>
  83.  
  84. Die, via a call CGI::Croak::croak, unless https/SSL is in effect. Prints an 
  85. HTML message suggesting the script be called via https://. This default message 
  86. can be changed with cgi_user_error_msg(). (An alternate spelling for this is 
  87. croak_unless_via_ssl.)
  88.  
  89. The default croak message is a convenient redirect to the same page via https. 
  90.  
  91. =cut
  92.  
  93. # error exit here unless SSL in effect
  94. sub croak_unless_via_SSL {
  95.     cgi_error_exit() unless cgi_is_via_SSL();
  96.     return 0;
  97. }
  98.  
  99. # added for those who hate capitalization :)
  100. sub croak_unless_via_ssl { croak_unless_via_SSL() }
  101.  
  102. =item B<redirect_unless_via_SSL> (alternate, redirect_unless_via_ssl)
  103.  
  104. Print a redirect and exit if not using https/SSL. Optional argument is to the
  105. redirection URL. Defaults to the current URL, but called via https://.
  106.  
  107. =cut
  108.  
  109. sub redirect_unless_via_SSL {
  110.     my $txt = shift || $redirect_msg;
  111.     unless(cgi_is_via_SSL()) { print $txt; exit }
  112.     return 1;
  113. }
  114. sub redirect_unless_via_ssl { redirect_unless_via_SSL(shift) }
  115.  
  116.  
  117. =item B<redirect_unless_via_HTTP> (alternate, redirect_unless_via_http)
  118.  
  119. Print a redirect and exit if not using regular, non-SSL http. 
  120. Optional argument is to the redirection URL. This allows a redirect away 
  121. from the https-only service back to a regular http service if the https 
  122. page is called for a page that is only available via regular http.
  123. Defaults to the current URL, but called via http://.
  124.  
  125. =cut
  126.  
  127. sub redirect_unless_via_HTTP {
  128.     my $txt = shift || $redirect_to_http_msg;
  129.     if(cgi_is_via_SSL()) { print $txt; exit }
  130.     return 1;
  131. }
  132. sub redirect_unless_via_http { redirect_unless_via_HTTP(shift) }
  133.  
  134.  
  135. =item B<cgi_user_error_msg>
  136.  
  137. Set and/or return the current error msg. The error message set by the user 
  138. should be fully HTML, except for the header which the routine prints first--
  139. ie, something like '<HTML><HEAD>NO SSL!</HEAD><BODY>Call us with https://</BODY></HTML>'.
  140.  
  141. =cut
  142.  
  143. # set and/or return the current error msg.
  144. # the error message set by the user should be fully HTML, ie 
  145. #  '<HTML><HEAD>NO SSL!</HEAD><BODY>Call us with https://</BODY></HTML>'
  146. sub cgi_user_error_msg {
  147.     my $msg = shift;
  148.     if($msg) { $user_msg = $msg }
  149.     return $user_msg ? $user_msg : $default_msg;
  150. }
  151.  
  152.  
  153. =item B<cgi_error_exit>
  154.  
  155. Prints our error message and exits.
  156.  
  157.  
  158. =cut
  159.  
  160. # print error message to stdout, then croak
  161. sub cgi_error_exit {
  162.     print $header_msg, cgi_user_error_msg();
  163.     croak "Bad call of this CGI: SSL/HTTPS not set--need https.";
  164. }
  165.  
  166.  
  167. # included mostly for testing purposes--probably not for use in real life
  168. sub new {
  169.     my ($class) = shift;
  170.     my $self = {};
  171.     bless $self, $class;
  172.     return $self;
  173. };
  174.  
  175.  
  176. =back
  177.  
  178. =head1 AUTHOR
  179.  
  180. William Herrera (wherrera@skylightview.com).
  181.  
  182. =head1 SUPPORT
  183.  
  184. Questions, feature requests and bug reports should go to wherrera@skylightview.com
  185.  
  186. =head1 COPYRIGHT
  187.  
  188. =over 4
  189.  
  190. Copyright (C) 2004, by William Herrera.  
  191. All Rights Reserved. 
  192.  
  193. =back
  194.  
  195. This module is free software; you can redistribute it and/or modify it under 
  196. the same terms as Perl itself. 
  197.  
  198. =cut
  199.  
  200. 1;
  201.