#!/usr/bin/perl
# ----------------------------------------------------------------------------
# This software is Copyright (C) 2007, All Rights Reserved
# ----------------------------------------------------------------------------
# This program is protected by local and international copyright laws. Any
# use of this program is subject to the the terms of the license agreement
# included as part of this distribution archive. Any other uses are strictly
# prohibited without the written permission of the Vendor and all
# other rights are reserved.
# -----------------------------------------------------------------------------
# Warning : Modifying this program violates your license agreement!
# -----------------------------------------------------------------------------

package IT::Common;

use strict;
use Socket qw(:DEFAULT :crlf);


# library globals
use vars qw(%URL_ESCAPED_CHARS);
for my $index (0..255) {
  my $char    = chr($index);
  my $escaped = sprintf("%%%02X", $index);
  $URL_ESCAPED_CHARS{$char} = $escaped;
}

our $CONTENT_HEADERS_SENT = 0;



# ----------------------------------------------------------------------------
# Function    : contentType
# Description : returns full content-type header for value passed in.  Will
#               never print more than one content header, even if called twice.
#
# Usage       : print &IT::Common::contentType('text/html');
# ----------------------------------------------------------------------------

sub contentType {
  my($mimeType) = shift || die "No mimetype specified!";

  # error checking
  unless (defined wantarray)        { &IT::Error::dieAsCaller("called function in void context!"); }
  if ($mimeType =~ /content-type/i) { &IT::Error::dieAsCaller("mimeType can't have 'content-type' in it!"); }
  if ($mimeType =~ /\n/)            { &IT::Error::dieAsCaller("mimeType can't have nextlines in it!"); }

  $CONTENT_HEADERS_SENT++;
  if ($CONTENT_HEADERS_SENT > 1) { return; }
  else                           { return "Content-type: $mimeType\n\n"; } #-- skip syntax check --#

}

# ----------------------------------------------------------------------------
# Function    : firstDefinedValue
# Description : Return the first defined() value from the list.  This is useful
#               when some of the values might be blank or be set to zero but
#               they're still defined such as when you want to maintain state
#               on a form and use a previously submitted form value if it's
#               defined, even if it's blank.
# Usage       : my $value = &firstDefinedValue($FORM->{'widgets'}, $widgets, "defaultValue");
# ----------------------------------------------------------------------------

sub firstDefinedValue {
  my @values     = @_;
  my $firstValue = undef;

  foreach my $value (@values) {
    if (defined $value) {
      $firstValue = $value;
      last;
    }
  }

  return $firstValue;
}


# ------------------------------------------------------------------------------
# Function    : getPage
# Description : make a request for a webpage and return the response
# Usage       : my $response = &IT::Common::getPage($hostname, $url);
# Usage       : my $response = &IT::Common::getPage($hostname, $url, $port);
# ------------------------------------------------------------------------------

sub getPage {
  my $hostname = shift || die "no hostname specified!";   # eg: www.website.sample
  my $url      = shift || die "no url specified!";        # eg: /cgi/env.cgi
  my $port     = shift || 80;

  # create socket
  my $tcpProto    = 0; # 0 defaults to TCP
  local(*SOCK);
  socket(SOCK, PF_INET, SOCK_STREAM, $tcpProto) || die "No socket: $!";

  # unbuffer socket
  select(SOCK);
  $|=1;
  select(STDOUT);

  # connect to site
  my $packedAddr = inet_aton($hostname) || return;           # if we can't resolve hostname, return
  my $sockaddrIn = pack_sockaddr_in($port, $packedAddr);
  connect(SOCK, $sockaddrIn) || return;                      # if we can't connect, return

  # send request
  print SOCK "GET $url HTTP/1.0" . $CRLF;
  print SOCK "Host: $hostname" . $CRLF;
  print SOCK "Referer: $ENV{'HTTP_REFERER'}" . $CRLF . $CRLF;


  # get response
  my $response = join("", <SOCK>);
  $response =~ s/$CRLF/$LF/gs;

  # close socket
  close(SOCK);

  #
  return $response;
}

# ----------------------------------------------------------------------------
# Function    : isSecureHttpsConnection
# Description :
# Usage       : &IT::Common::isSecureHttpsConnection()
# ----------------------------------------------------------------------------

sub isSecureHttpsConnection {

  if ($ENV{'HTTPS'} eq 'on') { return 1; }

  return 0;

}

# ----------------------------------------------------------------------------
# Function    : redirectBrowserToURL
# Description : redirect the browser using one or more methods.  If all the
#               headers haven't been sent yet a HTTP redirect header is sent.
#               In addition to that, a meta refresh tag and javascript redirect
#               are output.
# Usage       : &IT::Common::redirectBrowserToURL($url);
# ----------------------------------------------------------------------------

sub redirectBrowserToURL {
  my $url = shift || die "no url specified!";
  $url =~ s/ /%20/gs; # url encoded spaces

  my $htmlEncodedUrl = &IT::Common::htmlEncode($url);

  ### if content headers haven't been send yet sent http redirect and html content header
  if  ($CONTENT_HEADERS_SENT == 0) {

    # Fix IIS/5.0 bug "Set-Cookie Is Ignored in CGI When Combined With Location" described here: http://support.microsoft.com/kb/q176113/
    my $isIIS5 = ($ENV{'SERVER_SOFTWARE'} eq 'Microsoft-IIS/5.0');  # IIS 5.1 doesn't seem effected
    if ($isIIS5) {
      print &IT::Common::contentType('text/html');
      print qq|<META HTTP-EQUIV="refresh" CONTENT="0;URL=$htmlEncodedUrl">\n|;
      exit;
    }

    print "Location: $url\n";
    print &IT::Common::contentType('text/html');
    print qq|<META HTTP-EQUIV="refresh" CONTENT="0;URL=$htmlEncodedUrl">\n|;
    print "This page has moved. If you aren't automatically forwarded to the new location ";
    print "then click the following link: <a href='$htmlEncodedUrl'>$url</a>.\n";
    exit;
  }

  ### if content headers have already been sent use javascript and/or meta refresh to redirect user

  # use javascript to redirect user
  my $jsEncodedUrl = &IT::Common::javascriptEncode("'", $url);
  print "\n";
  print "\n<script>window.location = '$jsEncodedUrl';</script>\n";

  # use meta refresh to redirect url
  print qq|\n<META HTTP-EQUIV="refresh" CONTENT="0;URL=$htmlEncodedUrl">\n|;

  # print redirect message with link (in case other methods fail)
  print "\n<p>Redirect to <a href='$htmlEncodedUrl'>$url</a>.</p>\n";

  exit;
}

# ----------------------------------------------------------------------------
# URL    : URL encoding/decoding Perl routines.  URL encoding is an common
#          encoding scheme where non A-Za-z0-9\-_.!~*() characters are replaced
#          with a character triplet of "%" followed by the two hex digits.
#
# Usage  : $urlEncoded = &IT::Common::urlEncode("$plaintext");
#        : $plaintext   = &IT::Common::urlDecode("$urlEncoded");
# ----------------------------------------------------------------------------

sub urlEncode {
  my $text = shift;

  # Note:  We encode ' even though it's not required by the RFCs so that it's
  # easier for users to insert url encoded content into single quoted attribute
  # strings in html.

  $text =~ s/([^A-Za-z0-9\-_.!~*()])/$URL_ESCAPED_CHARS{$1}/g;

  return $text;                                         # return URL encoded text
}

sub urlDecode {
  my $text = shift;
  $text =~ tr/+/ /;                                     # replace "+" with " "
  $text =~ s/%([A-F0-9]{2})/pack('C', hex($1))/egi;     # replace %hex with chars
  return $text;                                         # return decoded plain text
}

# ------------------------------------------------------------------------
# Function    : htmlEncode
# Description : Encode html "chars" as entities to prevent html from being
#               displayed (actual html source will be displayed instead).
#
#               Use this to encode content when you don't want to display
#               HTML at all.  If the user submits "<b>" it will be "&lt;b&gt;"
#               in the source and display as "<b>".  Preventing html prevents
#               cross-site scripting (XSS) attacks.  You might use this to
#               encode a variable (such as a username) you were interpolating
#               into an html error message so the username couldn't contain
#               html but the error message could.
#
#               Another use is to encode form field values so they don't break
#               the input tag, however this would usually be done with the
#               placeholder modifier 'htmlEncoded'
#
# Usage       : &IT::Common::htmlEncode("<h1>hello &not_first_view</h1>");
# ------------------------------------------------------------------------

sub htmlEncode {
  my $html = shift;

  $html =~ s/&/&amp;/g;      # order is important here
  $html =~ s/"/&quot;/g;
  $html =~ s/'/&#39;/g;
  $html =~ s/</&lt;/g;
  $html =~ s/>/&gt;/g;

  return $html;
}

# ------------------------------------------------------------------------------
# Function    : javascriptEncode
# Description : encode a value so it can be used in a javascript string
# Usage       : my $encodedValue = &IT::Common::javascriptEncode($quoteChar, $value);
# ------------------------------------------------------------------------------

sub javascriptEncode {
  my $quoteChar = shift || die "no quote char specified!";
  my $value     = shift;

  # error checking
  if ($quoteChar ne "'" && $quoteChar ne '"') { die "quoteChar must be ' or \" not '$quoteChar'\n"; }

  # encode Value
  my $encodedValue = $value;
  $encodedValue =~ s/\\/\\\\/g;                # this line must be first to avoid double encoding \'s
  $encodedValue =~ s/'/\\'/g;
  $encodedValue =~ s/"/\\"/g;
  $encodedValue =~ s/\n/\\n/g;
  $encodedValue =~ s/\r/\\r/g;
  $encodedValue =~ s/<!--/<$quoteChar+$quoteChar!--/g;               # opening comment can comment out rest of script
  $encodedValue =~ s/-->/--$quoteChar+$quoteChar>/g;                 # closing comment tag can close script tag early if script is in comment, eg: <script><!--
  $encodedValue =~ s|<script>|<scr${quoteChar}+${quoteChar}ipt>|g;   # <script> will end (start?) script tag early
  $encodedValue =~ s|</script>|</scr${quoteChar}+${quoteChar}ipt>|g; # </script> will close script early even if it's just in a javascript string

  return $encodedValue;
}

# ------------------------------------------------------------------------
# Function    : mathCeiling
# Description : return integer greater than or equal to argument
# Usage       : $num = &IT::Common::mathCeiling($num);
# ------------------------------------------------------------------------

sub mathCeiling {
  my $num = shift;

  if ($num == int($num)) { return $num; }               # num is an integer
  elsif ($num < 0)       { return int $num; }           # num is negative
  else                   { return int($num)+1; }        # num is positive

}

# ------------------------------------------------------------------------
# Function    : mathFloor
# Description : return integer less than or equal to argument
# Usage       : $num = &IT::Common::mathFloor($num);
# ------------------------------------------------------------------------

sub mathFloor {
  my $num = shift;

  if ($num == int($num)) { return $num; }               # num is an integer
  elsif ($num < 0)       { return int($num)-1; }        # num is negative
  else                   { return int $num; }           # num is positive

}

# ------------------------------------------------------------------------
# Function    : mathMin
# Description : return the smallest of a given number of values
# Usage       : $num = &IT::Common::mathMin(1,2,3,4,5);
# ------------------------------------------------------------------------

sub mathMin {
  my (@values) = @_;

  my @sortedValues = sort {$a <=> $b} @values;
  my $maxValue     = $sortedValues[0];

  return $maxValue;
}

# ------------------------------------------------------------------------
# Function    : mathMax
# Description : return the largest of a given number of values
# Usage       : $num = &IT::Common::mathMax(1,2,3,4,5);
# ------------------------------------------------------------------------

sub mathMax {
  my (@values) = @_;

  my @sortedValues = sort {$a <=> $b} @values;
  my $maxValue     = $sortedValues[-1];

  return $maxValue;
}

# ------------------------------------------------------------------------
# Name          : getCompleteDomainWithTrailingDotOrIP
# Description   : fully qualifies a host to prevent potential DNS confusion
#                 (e.g. disambiguate 'domain.com' from 'domain.com.domain.com'
#                 by providing a trailing dot: 'domain.com.')
# Usage         : my $absoluteHost = &getCompleteDomainWithTrailingDotOrIP($hostOrIP);
# ------------------------------------------------------------------------
#   RFC 1123 (6.1.4.3) states that "User Interfaces [i.e. DNS service]
# provide a method for users to enter commonly-used names."  The document
# doesn't describe how to do this, but does mention that if it's done then
# there MUST be some convention for denoting that a name is already
# complete.  It goes on to suggest that "A trailing dot is the usual method."
#   It's therefore assumed that the trailing dot syntax is in common
# usage, but has not yet appeared officially in an RFC.
# ------------------------------------------------------------------------

sub getCompleteDomainWithTrailingDotOrIP {
  my ($host) = @_;

  ### If this is an IP address, it's already absolute
  if ($host =~ /^\d+\.\d+\.\d+\.\d+$/) {                                        # rfc 1123 2.1
    return $host;
  }

  ### If it's a hostname, add a '.' to the end if there isn't one already
  else {
    $host .= '.' unless $host =~ /\.$/;
    return $host;
  }
}

# ----------------------------------------------------------------------------
# Function    : redirect
# Description : redirect the browser to a new url
# Usage       : &redirect($url);
# ----------------------------------------------------------------------------

sub redirect {
  my $url = shift || die "no url specified!";

  my $urlEncodedUrl = &IT::Common::urlEncode($url);

  print &IT::Common::contentType('text/html');
  print <<__HTML__;
<html><head><title></title>
<meta http-equiv="Refresh" content="0;URL=$urlEncodedUrl">
</head>
<body></body>
</html>
__HTML__
exit;

}


# ----------------------------------------------------------------------------
# Function    : addSignalHandler
# Description : Add a handler to run first when a signal is called.  Always
#               exits after all handlers are run.  Don't exit in your handler
#               if you want any other handlers to be able to run after!
#
# Usage       : &IT::Common::addSignalHandler($signalName, $coderef);
#
# Inputs      : $signalName - the signal to be caught ('TERM', 'HUP', 'INT', or '__DIE__')
#               $coderef    - the code to run when the signal is caught
# Output      : no explicit return value.
#               dies if no signal name passed to it
#               dies if the coderef isn't a 'CODE' reference
#               dies if the signalName isn't supported by function
#
# Catch $SIG{TERM}, When a user hits stop in their browser Apache throws a SIG
# TERM, waits 3 seconds and then kills the process.  If the TERM isn't caught it
# kills the process right away.  Remember, we only have 3 seconds!
#
# Prior to Perl 5.7.3 it was necessary to do as little as you possibly could in
# your handler; notice how all we do is set a global variable and then raise an
# exception. That's because on most systems, libraries are not re-entrant;
# particularly, memory allocation and I/O routines are not. That meant that doing
# nearly anything in your handler could in theory trigger a memory fault and
# subsequent core dump - see Deferred Signals (Safe Signals) below.
#
# See:
# file:///X:/Perl/html/lib/Pod/perlipc.html#signals
# file:///X:/Perl/html/lib/Pod/perlipc.html#deferred_signals__safe_signals_
# ----------------------------------------------------------------------------

sub addSignalHandler {
  my $signalName = shift || die "no signal name specified";
  my $newHandler = shift;

  # error checking
  my $handlerRefType = ref($newHandler);
  if ($handlerRefType ne 'CODE') { die "Coderef isn't a 'CODE' reference, it's a '$handlerRefType'\n"; }
  if ($signalName ne 'TERM' &&
      $signalName ne 'HUP'  &&
      $signalName ne 'INT'  &&
      $signalName ne '__DIE__')  { die "Signal '$signalName' not support, must be either 'TERM', 'HUP', or '__DIE__'!"; }

  my $oldHandler = $SIG{$signalName};
  if ($oldHandler &&
      ref $oldHandler eq 'CODE')   { $SIG{$signalName} = sub { &$newHandler(); &$oldHandler(); }; }

  # if no handler defined
  elsif ($signalName eq '__DIE__') { $SIG{$signalName} = sub { &$newHandler(); die @_; }; }
  else                             { $SIG{$signalName} = sub { &$newHandler(); exit; }; }

}

# ----------------------------------------------------------------------------
# end of file
1;

