#!/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::ReadForm;

# load modules
use strict;

use IT::Globals;

# user defined globals (set by Init call)
use vars qw(@REQUIRED_USER_DEFINED_GLOBALS);
@REQUIRED_USER_DEFINED_GLOBALS = qw(ALLOW_UPLOADS UPLOAD_DIR DISABLE_CODE_BLOCKS);

# library globals
use vars qw($INIT_CALLED $READFORM_ALREADY_CALLED $TEMP_UPLOAD_DIR $UPLOAD_DIR $ALLOW_UPLOADS $DISABLE_CODE_BLOCKS $CODE_BLOCK_DISABLED_TEXT);
$INIT_CALLED              = 0;    # indicated whether init() has been called or not
$READFORM_ALREADY_CALLED  = 0;
$UPLOAD_DIR               = '';
$TEMP_UPLOAD_DIR          = '';
$ALLOW_UPLOADS            = 0;
$DISABLE_CODE_BLOCKS      = 0;
$CODE_BLOCK_DISABLED_TEXT = "<!-- (CODE BLOCK DISABLED) ";

use vars qw($MULTIPART_MAX_BUFFER_READ $MULTIPART_BYTES_READ $MAX_UPLOADS_PER_DIRECTORY $MULTIPART_BUFFER $MULTIPART_BOUNDARY $MAX_UNCLAIMED_UPLOAD_AGE);
$MULTIPART_MAX_BUFFER_READ = 10_000; # max bytes to read at a time when parsing multipart forms
$MULTIPART_BYTES_READ      = 0;
$MAX_UNCLAIMED_UPLOAD_AGE  = time() - (60*60);  # delete unclaimed uploads after 1 hour
$MAX_UPLOADS_PER_DIRECTORY = 10_000;



# ----------------------------------------------------------------------------
# Function    : init
# Description : define filepaths and globals required by library
# Usage       : &init({
#                 'ARGUMENT' => "$value",
#               });
#
# Note: Don't call any functions that call &_die_unless_init_called()
#       from this function because then we'll get a confusing error about the init
#       function not being called instead of the actual error.
# ----------------------------------------------------------------------------

sub init {
  my $args = shift;
  if (!$args)                     { die("no arguments specified!"); }
  if (ref $args ne 'HASH')        { die("args must be passed by hash ref!"); }

  # error checking
  my($thisSubroutine) = (caller(0))[3];
  foreach (@REQUIRED_USER_DEFINED_GLOBALS) {
    unless (exists $args->{$_}) { &IT::Error::dieAsCaller("required $thisSubroutine argument '$_' not defined"); }
  }

  ## set user defined globals
  $UPLOAD_DIR          = $args->{'UPLOAD_DIR'};
  $ALLOW_UPLOADS       = $args->{'ALLOW_UPLOADS'};
  $DISABLE_CODE_BLOCKS = $args->{'DISABLE_CODE_BLOCKS'};

  # set sub globals
  $INIT_CALLED = 1;

  # upload error checking
  if ($ALLOW_UPLOADS) {

    # UPLOAD_DIR
    if ($UPLOAD_DIR eq '')                      { die "Upload Directory isn't defined! Check Admin &gt; Server Settings\n"; }
    if (&IT::File::isRelativePath($UPLOAD_DIR)) { die "Upload Directory can't be a relative path!  Check Admin &gt; Server Settings\n"; }
    if (-e $UPLOAD_DIR && !-d $UPLOAD_DIR)      { die "Upload Directory isn't a directory!  Check Admin &gt; Server Settings\n"; }
    if ($UPLOAD_DIR && !-e $UPLOAD_DIR) {
      &IT::File::createDirPath($UPLOAD_DIR) || die "Couldn't create Upload Directory! Check permissions on:\n$UPLOAD_DIR\n";
    }
    if (!-w $UPLOAD_DIR)                        { die "Upload Directory isn't writable! Check permissions on:\n$UPLOAD_DIR\n"; }

    # TEMP_UPLOAD_DIR
    $TEMP_UPLOAD_DIR = "$UPLOAD_DIR/incoming/";
    if ($UPLOAD_DIR && !-e $TEMP_UPLOAD_DIR) {
      &IT::File::createDirPath($TEMP_UPLOAD_DIR) || die "Couldn't create Upload Directory! Check permissions on:\n$TEMP_UPLOAD_DIR\n";
    }
    if (!-w $TEMP_UPLOAD_DIR)                   { die "Upload Directory isn't writable! Check permissions on:\n$TEMP_UPLOAD_DIR\n"; }

    # check filelock::init called
    &IT::FileLock::die_unless_init_called();
  }

  # remove old unclaimed uploads
  if ($ALLOW_UPLOADS) {
    &_deleteOldUnclaimedUploads();
  }

}

# ----------------------------------------------------------------------------
# Function    : _die_unless_init_called()
# Description : Dies unless &init() has been called.  This is called
#               first by many public function to make sure the init function
#               for the module has been called.
# Usage       : &_die_unless_init_called();
# ----------------------------------------------------------------------------

sub _die_unless_init_called {
  if ($INIT_CALLED) { return; }

  my($thisPackage) = (caller(0))[0];
  my($subroutine) = (caller(1))[3];
  &IT::Error::dieAsCaller("You must call &${thisPackage}::init() before calling $subroutine",2);

}


# ----------------------------------------------------------------------------
# ReadForm : Read input from CGI form Perl Routine.  Parse input from a
#            GET or POST form and return a hash of form names and values.
#
# Usage    : &IT::ReadForm::readForm();
# ----------------------------------------------------------------------------

sub readForm {
  &_die_unless_init_called();

  # error checking
  if (defined wantarray)        { &IT::Error::dieAsCaller("return value expected from function that doesn't return anything!"); }
  if ($READFORM_ALREADY_CALLED) { &IT::Error::dieAsCaller("readForm can't be called multiple times!"); }
  $READFORM_ALREADY_CALLED = 1;

  # define defaults for globals
  $FORM         = {};
  $FORM_ARRAYS  = {};
  $FORM_UPLOADS = {};

  # skip non GET or POST forms
  my $isGetOrPostForm = $ENV{'REQUEST_METHOD'} eq 'GET' || $ENV{'REQUEST_METHOD'} eq 'POST';
  if (!$isGetOrPostForm) { return; }

  # call parsing function
  my $isMultipartForm = ($ENV{'REQUEST_METHOD'} eq 'POST' && $ENV{'CONTENT_TYPE'} =~ m|^multipart/form-data|);
  if ($isMultipartForm) { &_parseMultipartForm(); }   # for file uploads
  else                  { &_parseUrlEncodedForm(); }

}

# ----------------------------------------------------------------------------
# Function    :
# Description :
# Usage       :
# ----------------------------------------------------------------------------

sub _parseUrlEncodedForm {

  my $urlEncodedFormData;
  if    ($ENV{'REQUEST_METHOD'} eq 'POST') { read(STDIN, $urlEncodedFormData, $ENV{'CONTENT_LENGTH'}); }
  elsif ($ENV{'REQUEST_METHOD'} eq 'GET')  { $urlEncodedFormData = $ENV{'QUERY_STRING'}; }

  my @pairs = split(/&/, $urlEncodedFormData);
  foreach my $pair (@pairs) {
    my($encodedName, $encodedValue) = split(/=/, $pair, 2);

    my $name  = &IT::Common::urlDecode($encodedName);
    my $value = &IT::Common::urlDecode($encodedValue);

    &_addKeyValuePairToFormGlobals($name, $value);
  }
}

# ----------------------------------------------------------------------------
# function    : ReadForm_Multipart
# description : read multipart form submissions.  return reference to hash
# usage       : $hashref = &ReadForm_Multipart();
# known issues: a file upload with the same name as another field is not handled correctly
# ----------------------------------------------------------------------------

sub _parseMultipartForm {

  # Error checking
  if ($ENV{'REQUEST_METHOD'} ne 'POST')                { die "Multipart form isn't using POST method!"; }
  if ($ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data|) { die "Not multipart form!"; }

  # reset globals (for testplans)
  $MULTIPART_BYTES_READ = 0;
  $MULTIPART_BUFFER     = '';
  $MULTIPART_BOUNDARY   = '';

  # get boundary string
  unless ($ENV{'CONTENT_TYPE'} =~ /boundary="?(\S+?)"?$/) { die "Couldn't match boundary in CONTENT_TYPE: '$ENV{'CONTENT_TYPE'}'!"; }
  $MULTIPART_BOUNDARY = $1;

  ### Loop through multipart of form-data, separated by --$boundary, ended by --$boundary--
  while (1) {

    # match end of input
    if ($MULTIPART_BUFFER eq '') { &_readMoreMultipartInputIntoBuffer(); }
    if ($MULTIPART_BUFFER =~ /^--\Q$MULTIPART_BOUNDARY\E--$CRLF$/) { last; }

    # load field headers
    my $fieldHeaders = &_loadMultipartFieldHeaders();
    my $name         = $fieldHeaders->{'name'};

    # add form fields to $FORM and $FORM_ARRAYS
    my $isFileUpload = exists $fieldHeaders->{'filename'};
    if (not $isFileUpload) {
      my $value = &_loadMultipartFieldValue();
      &_addKeyValuePairToFormGlobals($name, $value);
    }

    # save file uploads and add to $FORM_UPLOADS
    if ($isFileUpload) {
      if (exists $FORM_UPLOADS->{$name}) { die "You cannot upload more than one file with the same fieldname ($name)!"; }
      my $tempFilePath = &_saveMultipartUploadAsTempFile($fieldHeaders->{'filename'});

      if (!$fieldHeaders->{'filename'}) { next; } # skip files with no filename

      $FORM_UPLOADS->{$name} = {
        'userFileName' => $fieldHeaders->{'filename'},
        'tempFilePath' => $tempFilePath,
      };

    }
  }

}

# ------------------------------------------------------------------------------
# Function    :
# Description :
# Note        :
# Usage       : &_readMoreMultipartInputIntoBuffer();
# ------------------------------------------------------------------------------

sub _readMoreMultipartInputIntoBuffer {
  my $remainingBytes = $ENV{'CONTENT_LENGTH'} - $MULTIPART_BYTES_READ;
  my $bytesToRead    = &IT::Common::mathMin($remainingBytes, $MULTIPART_MAX_BUFFER_READ);

  # error checking
  if ($remainingBytes <= 0)  { die("_readMoreMultipartInputIntoBuffer: No more bytes remain to be read!"); }

  # load more data into buffer
  binmode(STDIN);   # don't convert line endings when reading data
  my $tempBuffer;
  $MULTIPART_BYTES_READ += read(STDIN, $tempBuffer, $bytesToRead) || die "Error reading multipart input! $!";
  $MULTIPART_BUFFER     .= $tempBuffer;
};

# ------------------------------------------------------------------------------
# Function    : _loadMultipartFieldHeaders
# Description : parse out next field header from multipart form input, remove
#              it from the buffer and return a hash with the field name and
#              filename (for file uploads).
# Usage       : my $headers = &_loadMultipartFieldHeaders();
# ------------------------------------------------------------------------------

sub _loadMultipartFieldHeaders {

  ### parse header from buffer
  my $headerText;
  while (1) {
    if ($MULTIPART_BUFFER =~ s/^--\Q$MULTIPART_BOUNDARY\E$CRLF(.+?)$CRLF$CRLF//s) {
      $headerText = $1;
      last;
    }
    &_readMoreMultipartInputIntoBuffer();
    if (length $MULTIPART_BUFFER > 10_000) { die "Couldn't find end of field header!"; }
  }

  ### parse fields from header
  my $headers = {};
  if ($headerText =~ /name="(.*?)"/)     { $headers->{'name'} = $1; }
  if ($headerText =~ /filename="(.*?)"/) { $headers->{'filename'} = $1; }
  unless (exists $headers->{'name'})     { die "Couldn't match field name in multipart header!"; }

  ### Remove path from filename value (ie6 submits full filepath, moz1 submits filename only)
  if (exists $headers->{'filename'}) {
    $headers->{'filename'} =~ s!^.*(\\|/)!!s;
  }

  return $headers;
}

# ------------------------------------------------------------------------------
# Function    : _loadMultipartFieldValue
# Description :
# Usage       : my $value = &_loadMultipartFieldValue();
# ------------------------------------------------------------------------------

sub _loadMultipartFieldValue {

  ### keep loading content until end of content boundary marker
  my $value;
  while (1) {
    if ($MULTIPART_BUFFER =~ s/^(.*?)$CRLF(?=--\Q$MULTIPART_BOUNDARY\E)//s) {
      $value = $1;
      last;
    }
    &_readMoreMultipartInputIntoBuffer();
  }

  return $value;
}

# ------------------------------------------------------------------------------
# Function    : _saveMultipartUploadAsTempFile
# Description :
# Usage       : my $tempFile = &_saveMultipartUploadAsTempFile();
# ------------------------------------------------------------------------------

sub _saveMultipartUploadAsTempFile {
  my $userFilename = shift;

  # create temp file
  my $tempFileName;
  my $tempFilePath;
  if ($userFilename) {
    &IT::FileLock::getLock('exclusive');
    $tempFileName = &IT::File::createUniqueFilename($TEMP_UPLOAD_DIR, '', '.upload');  # might create news_1105045791000.html
    $tempFilePath = "$TEMP_UPLOAD_DIR/$tempFileName";
    &IT::File::writeFile($tempFilePath, '') || die "Can't write tempfile '$tempFilePath': $!";
    &IT::FileLock::releaseLock();
  }

  # Save uploaded file in chunks to avoid loading it all into memory at once
  while (1) {

    # read more input into buffer
    my $remainingBytesInBuffer = $ENV{'CONTENT_LENGTH'} - $MULTIPART_BYTES_READ;
    if ($remainingBytesInBuffer) {
      &_readMoreMultipartInputIntoBuffer();
    }

    ### if end boundary is in buffer, remove and return file data
    if ($MULTIPART_BUFFER =~ s/^(.*?)$CRLF(?=--\Q$MULTIPART_BOUNDARY\E)//ms) {
      my $partialContent = $1;

      if ($userFilename) {
        &IT::FileLock::getLock('exclusive');
        &IT::File::appendFile($tempFilePath, $partialContent) || die "Can't append to tempfile '$tempFilePath': $!";
        &IT::FileLock::releaseLock();
      }

      last;
    }

    ### otherwise - keep appending content to tempfile until content boundary is reached

    # NOTE:  We don't want to grab everything in the buffer, because the buffer might contain
    # half of a boundary marker.  That wouldn't match as a full boundary, but removing it would
    # prevent the boundary from matching on the next interation.  So we leave the length of the
    # full boundary at the end of the buffer so any partial boundaries won't be split in two and missed.

    # load partialContent from boundary, leaving space at end for partial boundary that wasn't matched yet
    my $maxBoundarySize         = length($MULTIPART_BOUNDARY) + 8; # 8 extra bytes for CR LF -- ... -- CR LF
    my $multipartBufferLength   = length($MULTIPART_BUFFER);
    my $maxBytesToRead          = $multipartBufferLength - $maxBoundarySize;
    $MULTIPART_BUFFER =~ s/^(.{$maxBytesToRead})//s || die "Couldn't match content in multipart buffer!";
    my $partialContent = $1;

    # append content to file
    if ($userFilename) {
      &IT::FileLock::getLock('exclusive');
      &IT::File::appendFile($tempFilePath, $partialContent) || die "Can't append to tempfile '$tempFilePath': $!";
      &IT::FileLock::releaseLock();
    }
  }

  return $tempFilePath;
}

# ------------------------------------------------------------------------------
# Function    : _addKeyValuePairToFormGlobals
# Description : Take an url encoded key/value pair, decode it, apply rules and
#               filters and add it to the FORM globals.
# Usage       : &_addKeyValuePairToFormGlobals($name, $value);
# ------------------------------------------------------------------------------

sub _addKeyValuePairToFormGlobals {
  my($name, $value) = @_;

  # apply input filters and rules
  ($name, $value) = &_applyInputFiltersAndRules($name, $value);

  # add to $FORM
  $FORM->{$name} = $value;

  # add to $FORM_ARRAYS
  push @{$FORM_ARRAYS->{$name}}, $value;

}

# ------------------------------------------------------------------------------
# Function    : _applyInputFiltersAndRules
# Description : Remove potential security risks from input, unexpected line endings
#               and add/modify keys to make things easier to access from the application
# Usage       : my($name, $value) = &_applyInputFiltersAndRules($name, $value);
# ------------------------------------------------------------------------------

sub _applyInputFiltersAndRules {
  my($name, $value) = @_;

  # error checking
  if (@_ != 2)       { die "_applyInputFiltersAndRules requires exactly 2 arguments!"; }
  unless (wantarray) { die "_applyInputFiltersAndRules must be called in a list context!"; }

  ### apply filters and rules

  # Convert image submit button vars (var.x & var.y) to normal vars (var)
  if ($name =~ /^(.*)(\.x|\.y)$/ && not exists $FORM_ARRAYS->{$1}) {
    my $keyName = &IT::Common::urlDecode($1);

    &_addKeyValuePairToFormGlobals($keyName, "true");
  }

  # replace \r\n with \n
  $name  =~ s/\r\n/\n/g;
  $value =~ s/\r\n/\n/g;

  # remove null strings
  $name  =~ s/\x00//g;
  $value =~ s/\x00//g;

  # Allow name/value pair in name attribute.  eq: <input type="submit" name="action=sampleList" value="Refresh">
  if ($name =~ /^([^=]*)=(.*)$/) {
    $name = $1;
    $value = $2;
  }

  # Disable PHP/ASP Code Blocks <? ?> <% %>
  if ($DISABLE_CODE_BLOCKS) {
    while ($name  =~ s/<\s*([\?\%])/$CODE_BLOCK_DISABLED_TEXT$1/sg) { 1 };
    while ($value =~ s/<\s*([\?\%])/$CODE_BLOCK_DISABLED_TEXT$1/sg) { 1 };
  }

  return($name,$value);
}

# ------------------------------------------------------------------------------
# Function    : reEnableDisabledCodeBlocks
# Description : remove code that was added to disable code blocks.  Filters all
#               global
# Usage       : my $enabledValue = &IT::ReadForm::reEnableDisabledCodeBlocks($disabledValue);
# ------------------------------------------------------------------------------

sub reEnableDisabledCodeBlocks {
  my $value = shift;

  $value =~ s/\Q$CODE_BLOCK_DISABLED_TEXT\E/</g;

  return $value;
}

# ------------------------------------------------------------------------------
# Function    : _deleteOldUnclaimedUploads
# Description : Delete unclaimed uploads that are older than $MAX_UNCLAIMED_UPLOAD_AGE
# Usage       : &_deleteOldUnclaimedUploads();
# ------------------------------------------------------------------------------

sub _deleteOldUnclaimedUploads {

  if (!-d $TEMP_UPLOAD_DIR) { return; }

  # list unclaimed uploads
  my $fh = &IT::File::createFilehandle();
  opendir($fh, $TEMP_UPLOAD_DIR) || die "couldn't open dir '$TEMP_UPLOAD_DIR'!";
  my @uploads = grep /\.upload/, readdir($fh);
  closedir($fh);

  # delete files with modified date older than $MAX_UNCLAIMED_UPLOAD_AGE
  foreach my $file (@uploads) {
    my $filepath     = "$TEMP_UPLOAD_DIR/$file";
    my $lastModified = (stat($filepath))[9];
    if ($lastModified <= $MAX_UNCLAIMED_UPLOAD_AGE) {
      unlink $filepath;
    }
  }

}

# ------------------------------------------------------------------------------
# Function    : claimUpload
# Description : move and rename an uploaded file from the incoming directory into
#               permanent numbered folder under uploads.  Numbered folders are used
#               to  prevent having too many files in one directory since OSs have
#               limits on how many files or directories can be under a folder
# Usage       : my $newFilePath = &IT::ReadForm::claimUpload($tempFilePath, $requestedFileName);
# ------------------------------------------------------------------------------

sub claimUpload {
  my $tempFilePath = shift;
  my $assignedFileName = shift;

  # error checking
  unless (-e $tempFilePath)                     { die "claimUpload: tempFilePath '$tempFilePath' doesn't exist!"; }
  unless (-f $tempFilePath)                     { die "claimUpload: tempFilePath '$tempFilePath' isn't a file!"; }

  # get valid assignedFileName and extension
  $assignedFileName =~ s/[^0-9a-z\.\-\_]/_/ig;
  $assignedFileName =~ s/\.\./__/ig;
  $assignedFileName =~ s/^\./_/ig;
  $assignedFileName =~ s/\.(\w+)$// || die "couldn't match file extension on '$assignedFileName'!";
  my $assignedFileExt = $1;

  # find unused filename and get valid filepath
  my $assignedFilePath;
  my $balancedUploadDir = &_getBalancedUploadDir();
  my $counter;
  while (!$assignedFilePath || -e $assignedFilePath) {
    $assignedFilePath = "$balancedUploadDir/$assignedFileName";
    $assignedFilePath .= "_$counter" if $counter;
    $assignedFilePath .= ".$assignedFileExt";
    $counter++;
  }

  # copy file to new directory
  &IT::File::copyFile($tempFilePath, $assignedFilePath) || die "Couldn't copy tempfile '$tempFilePath' to '$assignedFilePath'!";

  # remove old tempfile
  unlink($tempFilePath);

  # return new filepath
  return $assignedFilePath;

}

# ------------------------------------------------------------------------------
# Function    : _getBalancedUploadDir
# Description : Return the highest numbered subdirectory under $UPLOAD_DIR that
#               has less than $MAX_UPLOADS_PER_DIRECTORY in it, OR create a new
#               highest number directory if nessicary.  Basically we store uploads
#               in multiple folders under uploads to avoid max files per folder
#               limits imposed by operating systems.
# Usage       : my $balancedUploadDir = &_getBalancedUploadDir();
# ------------------------------------------------------------------------------

sub _getBalancedUploadDir {

  my $highestDirPath = '';

  ### find highest directory number
  my $fh = &IT::File::createFilehandle();
  opendir($fh, $UPLOAD_DIR) || die "couldn't open dir '$UPLOAD_DIR'!";
  my @dirs = grep { -d "$UPLOAD_DIR/$_" } readdir($fh);
  closedir($fh);

  my @sortedDirs = sort { $a <=> $b } grep { /^[0-9]+$/ } @dirs;
  my $highestDirNumber = $sortedDirs[-1] || 1;

  ### Create directory if it doesn't exist
  $highestDirPath = "$UPLOAD_DIR/$highestDirNumber";
  &IT::File::createDirPath($highestDirPath) || die "Couldn't create dir '$highestDirPath'!";

  ### get filecount in highest dir
  my $fh2 = &IT::File::createFilehandle();
  opendir($fh2, $highestDirPath) || die "couldn't open dir '$highestDirPath'!";
  my @files = grep !/^\.+$/, readdir($fh2);
  closedir($fh2);
  my $fileCount = scalar @files;

  ### Create new directory if needed
  if ($fileCount >= $MAX_UPLOADS_PER_DIRECTORY) {
    my $newDirNumber = $highestDirNumber + 1;
    $highestDirPath = "$UPLOAD_DIR/$newDirNumber";
    &IT::File::createDirPath($highestDirPath) || die "Couldn't create dir '$highestDirPath'!";
  }

  return $highestDirPath;

}

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

