File Coverage

blib/lib/lib/http.pm

Criterion	Covered	Total	%
statement	31	436	7.1
branch	3	260	1.1
condition	0	143	0.0
subroutine	9	30	30.0
pod	0	23	0.0
total	43	892	4.8

#############################################################################
## Name:        http.pm
## Purpose:     lib::http
## Author:      Graciliano M. P.
## Modified by:
## Created:     2005-02-04
## RCS-ID:
## Copyright:   (c) 2005 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package lib::http ;

  use strict qw(vars) ;

  use vars qw($VERSION @ISA $DEBUG %STATUS) ;

  $VERSION = '0.01' ;

###########
# REQUIRE #
###########

  use Socket ;

########
# VARS #
########

  my $AGENT = "lib::http/$VERSION Perl/$] ($^O)" ;

  my @MONTHS_DAYS = ('',31,28,31,30,31,30,31,31,30,31,30,31) ;

  my ( $ACCEPT_GZIP , $ENABLE_GZIP , @IDX_FIND , $FIND_IDX , %LIBS_IDX  , @TMPDIRS ) ;
  my ( $TMPDIR , $TMPFILE , @INC_LIB , %INC_LIB , %URLS , %LIB_TREE ) ;

  use constant URI_TIMEOUT => 60 ;
  use constant USER_AGENT => "perl-lib-httpd/$VERSION libwww-perl/$LWP::VERSION Perl/$] ($^O)" ;

  my @STATIC_TMPDIR = qw(libhttp lib/libhttp-tmp) ;

  my $LIB_VER = $] ;
  $LIB_VER =~ s/(\d+)\.(\d\d\d)(\d\d\d)/$1 .'.'. ($2*1) .'.'. ($3*1)/ge ;

  my @LIB_VERSIONED = (
  'lib','site/lib', ## win32
  'perl5','site_perl','perl5/site_perl','perl5/vendor_perl' , ## linux
  ) ;

  {
    my @copy = @LIB_VERSIONED ;
    foreach my $LIB_VERSIONED_i ( @copy ) {
      push(@LIB_VERSIONED , "$LIB_VERSIONED_i/$LIB_VER") ;
    }
  }

  my %MONTHS_EG = (
  'jan' => 1 ,
  'feb' => 2 ,
  'mar' => 3 ,
  'apr' => 4 ,
  'may' => 5 ,
  'jun' => 6 ,
  'jul' => 7 ,
  'aug' => 8 ,
  'sep' => 9 ,
  'oct' => 10 ,
  'nov' => 11 ,
  'dec' => 12
  );

##########
# IMPORT #
##########

sub import {
  my $class = shift ;

  if ( @_ == 1 ) {
    if ( $_[0] eq 'unlink_tmpfile' ) {
      unlink_tmpfile(1) ;
      return ;
    }
    elsif ( $_[0] =~ /debug/i ) {
      $DEBUG = 1 ;
      return ;
    }
  }


  my ( @bases ) = @_ ;

  start() if @bases ;

  my %idx ;

  foreach my $bases_i ( @bases ) {
    my $uri = $bases_i ;
    $uri =~ s/\/*$/\// ;

    if ( !$INC_LIB{$uri}++ ) {
      push(@INC_LIB , $uri) ;
      push(@IDX_FIND , $uri) ;

      foreach my $LIB_VERSIONED_i ( @LIB_VERSIONED ) {
        my $uri_ver = "$uri$LIB_VERSIONED_i" ;
        $uri_ver =~ s/\/*$/\//gs ;
        if ( scalar get_head($uri_ver) && !$INC_LIB{$uri_ver}++ ) {
          push(@INC_LIB , $uri_ver) ;
          push(@IDX_FIND , $uri_ver) ;
        }
      }
    }
  }

}

#########
# START #
#########

sub start {
  if ( !$TMPDIR ) {
    foreach my $STATIC_TMPDIR_i ( @STATIC_TMPDIR ) {
      if ( -d $STATIC_TMPDIR_i ) {
        $TMPDIR = $STATIC_TMPDIR_i ;
        last ;
      }
    }

    if ( !$TMPDIR ) {
      my $tmp = tmpdir() ;
      if ( $tmp && -d $tmp ) {
        my @lyb = (a..z,0..9) ;
        my $rand ;
        $rand .= $lyb[ rand(@lyb) ] while length($rand) < 6 ;
        $tmp .= '/' if $tmp !~ /[\\\/]$/ ;
        $tmp .= "libhttp-$rand-tmp" ;
        mkpath($tmp) ;
        if ( -d $tmp ) {
          $TMPDIR = $tmp ;
          push(@TMPDIRS , $TMPDIR) ;
        }
      }
    }

    $TMPFILE = "$TMPDIR/libhttp.tmp" ;
  }

  my ($hash_hook , $has_lib) ;
  foreach my $INC_i ( @INC ) {
    $hash_hook = 1 if $INC_i == \&hook ;
    $has_lib = 1 if $INC_i eq $TMPDIR ;
  }

  push(@INC , \&hook) if !$hash_hook ;
  push(@INC , $TMPDIR) if !$has_lib ;

  $SIG{INT} = \&end if !$SIG{INT} ;

  return 1 ;
}

###############
# ENABLE_GZIP #
###############

sub enable_gzip {
  return if $ENABLE_GZIP ;
  $ENABLE_GZIP = 2 ;

  eval('use Compress::Zlib ;') ;

  if ( !$@ && defined &Compress::Zlib::memGunzip ) {
    $ACCEPT_GZIP = 1 ;
    print ">> *** GZIP ON ***\n" if $DEBUG ;
  }

  $ENABLE_GZIP = 1 ;
}

############
# FIND_IDX #
############

sub find_idx {
  return if $FIND_IDX ;
  $FIND_IDX = 1 ;

  my %idx ;

  foreach my $IDX_FIND_i ( @IDX_FIND ) {
    my $fl_idx = "${IDX_FIND_i}libhttp.idx" ;

    my $fl_idx_local = $fl_idx ;
    $fl_idx_local =~ s/^http:\/\///si ;
    $fl_idx_local =~ s/\./_/gs ;
    $fl_idx_local =~ s/\W/-/gs ;
    $fl_idx_local =~ s/_idx$/.idx/gi ;

    $fl_idx_local = "$TMPDIR/$fl_idx_local" ;

    my ($idx , $idx_time) ;

    my ($fl_size , $mdf_time) = (stat($fl_idx_local))[7,9] ;
    if ( $fl_size ) {
      my ( $code , $modf , $length ) = get_head($fl_idx) ;

      if ( $code == 200 && $fl_size == $length && $mdf_time >= $modf ) {
        $idx_time = $mdf_time ;
        open (IDX,$fl_idx_local) ; binmode(IDX) ;
        1 while( read(IDX, $idx , 1024*4 , length($idx) ) ) ;
        close(IDX) ;
      }
    }

    if ( !$idx ) {
      my $modf ;
      ( $idx , undef , $modf ) = get_url("$fl_idx.gz" , undef , 1) if $ENABLE_GZIP ;
      ( $idx , undef , $modf ) = get_url($fl_idx      , undef , 1) if !$idx ;

      if ( $idx ) {
        $idx_time = $modf ;
        open (IDX,">$fl_idx_local") ; binmode(IDX) ;
        print IDX $idx ;
        close (IDX) ;
        utime($modf , $modf , $fl_idx_local) ;
      }
    }

    $idx{$IDX_FIND_i} = [$idx , $idx_time] if $idx ;
  }

  foreach my $Key (sort keys %idx ) {
    $LIBS_IDX{lib}{$Key} = $idx{$Key}[1] ;

    my (@files) = split( /(?:"\r\n?|\n)+/s , $idx{$Key}[0] ) ;

    foreach my $files_i ( @files ) {
      my ($file , $size) = split(/\s+=\s+/s , $files_i) ;
      $size =~ s/\s+//gs ;
      $LIBS_IDX{"$Key$file"} = $size ;
      $LIBS_IDX{libs}{"$Key$file"} = [$Key , $file] ;
      my ($dir) = ( $file =~ /(.*?)[^\\\/]+$/ ) ;
      $LIBS_IDX{dirs}{"$Key$dir"} = 1 ;
      $LIBS_IDX{path}{$dir}{$Key} = 1 ;
    }
  }

  ##print "*** IDX ON!\n" ;  ;

}

########
# HOOK #
########

sub hook {
  my $code = shift ;
  my $module = shift ;

  unlink_tmpfile() ;

##  enable_gzip() ;
##  find_idx() if $ENABLE_GZIP != 2 ;

  find_idx() ;
  enable_gzip() ;

  foreach my $INC_LIB_i ( @INC_LIB ) {
    my $uri = $INC_LIB_i . $module ; #URI->new_abs($module , $INC_LIB_i)->canonical ;
    check_module_dep($uri , $module) ;
    my $fl = get_file($uri , $module) ;
    return $fl if ref $fl ;
    last if $fl ;
  }

  ## Return undef since tmpdir is at @INC:
  return undef ;
}

####################
# CHECK_MODULE_DEP #
####################

sub check_module_dep {
  my ( $url , $module ) = @_ ;

  my $pack = $module ;
  $pack =~ s/[\\\/]/::/gs ;
  $pack =~ s/\.(?:pm|pl|al)$//si ;
  $pack =~ s/::/\//gs ;
  $pack =~ s/[\\\/]*$/\//s ;

  my @dep ;

  foreach my $INC_LIB_i ( @INC_LIB ) {
    push(@dep , [$INC_LIB_i , $pack]) ;
    push(@dep , [$INC_LIB_i , "auto/$pack"]) ;
  }

  foreach my $dep_i ( @dep ) {
    get_tree(@$dep_i) ;
  }
}

############
# GET_TREE #
############

sub get_tree {
  my ( $inc_base , $dir ) = @_ ;

  #print "DEP> $inc_base $dir\n" ;

  my @files ;

  if ( %LIBS_IDX && $LIBS_IDX{dirs}{"$inc_base$dir"} ) {
    foreach my $Key ( sort keys %LIBS_IDX ) {
      next if !$LIBS_IDX{$Key} || $Key =~ /\.gz$/ || $Key !~ /^\Q$inc_base$dir\E/ ;
      if ( $inc_base =~ /^\Q$LIBS_IDX{libs}{$Key}[0]\E/ && $Key =~ /^\Q$inc_base\E(.*)/ ) {
        push(@files , $1) ;
      }
    }
  }

  if ( !@files ) {
    my $has_lib_idx ;
    foreach my $Key ( keys %{ $LIBS_IDX{lib} } ) {
      $has_lib_idx = 1 if $inc_base =~ /^\Q$Key\E/i ;
    }
    @files = get_dir("$inc_base$dir" , $dir) if !$has_lib_idx ;
  }

  foreach my $files_i ( @files ) {
    ##print "FL> $inc_base > $files_i\n" ;
    if ( $files_i =~ /\/$/ ) {
      get_tree($inc_base , $files_i) ;
    }
    else {
      get_file("$inc_base$files_i" , $files_i) if $files_i !~ /\.pm$/ ;
    }
  }

}

#####################
# GET_DIR_RECURSIVE #
#####################

sub get_dir_recursive {
  my ( $inc_base , $dir ) = @_ ;

  my @files = get_dir("$inc_base$dir" , $dir) ;

  my @tree ;

  foreach my $files_i ( @files ) {
    if ( $files_i =~ /\/$/ ) {
      push(@tree , get_dir_recursive($inc_base , $files_i) ) ;
    }
    else {
      push(@tree , $files_i) ;
    }
  }

  return @tree ;
}

###########
# GET_DIR #
###########

sub get_dir {
  my ( $url_base , $pack_base ) = @_ ;

  my $dir = get_url($url_base , undef , 1) ;

  return if !$dir ;

  my @files = parse_dir($dir) ;

  foreach my $files_i ( @files ) {
    $files_i = "$pack_base$files_i" ;
  }

  return @files ;
}

#############
# PARSE_DIR #
#############

sub parse_dir {
  my ( $dir ) = @_ ;

  my (@links) = ( $dir =~ /]*?href=['"]([^'"]+)['"]>.*?<\/a>/gsi );

  my @files ;
  foreach my $links_i ( @links ) {
    next if $links_i !~ /(?:\w|\/)$/ || $links_i =~ /^(?:mailto:|\?|\/)/ ;
    push(@files , $links_i) ;
  }

  return @files ;
}

#################
# GET_MODULE_FH #
#################

sub get_module_fh {
  my ( $uri , $module ) = @_ ;

  my $new_file ;

  $new_file = get_file($uri , $module) || return ;

  open (my $fh , $new_file) ; binmode($fh) ;
  return $fh ;
}

############
# GET_FILE #
############

sub get_file {
  my ( $uri , $module ) = @_ ;

  return if (time - $URLS{$uri}{t}) < URI_TIMEOUT && $URLS{$uri}{status} == 404 ;

  my $new_file = $TMPDIR =~ /[\\\/]$/ ? "$TMPDIR$module" : "$TMPDIR/$module" ;
  my $file_dir = $new_file ;
  $file_dir =~ s/[^\\\/]+$//gs ;
  mkpath($file_dir) ;

  if ( -s $new_file && $LIBS_IDX{$uri} ) {
    my ($fl_size , $mdf_time) = (stat($new_file))[7,9] ;
    my $idx_time ;
    foreach my $Key ( sort keys %{ $LIBS_IDX{lib} } ) {
      $idx_time = $LIBS_IDX{lib}{$Key} if $uri =~ /^\Q$Key\E/i ;
    }

    return $new_file if $LIBS_IDX{$uri} == $fl_size && $idx_time ;

    my ( $code , $modf , $length ) = get_head($uri) ;

    return $new_file if $code == 200 && $fl_size == $length && $mdf_time >= $modf ;
    return if $code != 200 ;
  }

  my ($data , $code , $fl_time) ;

  if ( $ACCEPT_GZIP && $uri !~ /(?:\.gz|\/)$/i ) {
    my $uri_gz = "$uri.gz" ;
    if ( %LIBS_IDX && $LIBS_IDX{$uri_gz} ) {
      ($data , $code , $fl_time) = get_url($uri_gz) ;
      $data = '' if $code != 200 ;
    }
  }

  if ( $data eq '' && %LIBS_IDX ) {
    my $has_lib_idx ;
    foreach my $Key ( keys %{ $LIBS_IDX{lib} } ) {
      $has_lib_idx = 1 if $uri =~ /^\Q$Key\E/i ;
    }
    return if $has_lib_idx && !$LIBS_IDX{$uri} ;
  }

  unlink($new_file) ;

  ($data , $code , $fl_time) = get_url($uri) if $data eq '' ;

  $URLS{$uri}{t} = time ;
  if ( $data eq '' || $code != 200 ) {
    $URLS{$uri}{status} = 404 ;
    return ;
  }
  else {
    $URLS{$uri}{status} = 200 ;
  }

  if ( is_file_hidden(undef , $data) ) {
    $data =~ s/(?:\r\n?|\n)__END__(?:\r\n?|\n).*?$//s ;
    $data =~ s/(?:\r\n?|\n)__DATA__(?:\r\n?|\n).*?$//s ;

    open (my $fh,">$TMPFILE") ; binmode($fh) ;
    print $fh $data ;
    print $fh "\n\n use lib::http 'unlink_tmpfile' ;\n\n" ;
    close ($fh) ;

    open (TMPFILE,$TMPFILE) ; binmode(TMPFILE) ;
    return \*TMPFILE ;
  }

  open (my $fh,">$new_file") ; binmode($fh) ;
  print $fh $data ;
  close ($fh) ;

  utime($fl_time , $fl_time , $new_file) ;

  return if !-s $new_file ;

  return $new_file ;
}

############
# GET_HEAD #
############

sub get_head {
  return if %LIBS_IDX && $LIBS_IDX{lib}{$LIBS_IDX{libs}{$_[0]}[0]} && !$LIBS_IDX{$_[0]} ;
  return get_url($_[0],1,1) ;
}

###########
# GET_URL #
###########

sub get_url {
  my ( $url , $head , $force ) = @_ ;

  unlink_tmpfile() ;

  return if !$force && (time - $URLS{$url}{t}) < URI_TIMEOUT && ($URLS{$url}{status} == 404 || $url =~ /\/$/) ;

  #print ">> $url\n" if !$head ;

  my ( $host , $port , $path ) = ( $url =~ m,^http://([^/:]+)(?::(\d+))?(/\S*)?$, ) ;
  if ($host !~ /\w/s) { return ;}

  if ($port eq '' || $port == 0 || $port !~ /^[\d]+$/) { $port = 80 ;}
  if ($path eq '') { $path = '/' ;}

  my $socket ;

  for(1..3) {
    $socket = new_socket($host , $port) ;
    last if $socket ;
  }

  my $proto = $head ? 'HEAD' : 'GET' ;

  my $netloc = $host ;
  $netloc .= ":$port" if $port != 80 ;

  print $socket join("\015\012",
  "$proto $path HTTP/1.0" ,
  "Host: $netloc" ,
  ($ACCEPT_GZIP ? 'Accept-Encoding: gzip' : () ) ,
  "User-Agent: $AGENT" ,
  'Connection: close' ,
  '',''
  ) ;

  my $buffer ;
  while( read($socket, $buffer , 1024*4 , length($buffer) ) ) {
    #$buffer =~ s/\r\n?/\n/gs ;
    #print "$buffer\n" ;
  } ;

  close($socket) ;

  #print "$buffer\n" ;

  my ($headers , $content) = split(/(?:\015\012|\r\n){2}/ , $buffer , 2) ;

  ++$STATUS{loads} ;
  $STATUS{bandwidth} += length($buffer) ;

  if ( $DEBUG ) {
    print ">> $url\n" ;
    print ">> LOADS> $STATUS{loads}\n" ;
    print ">> BANDWIDTH> ". ( int($STATUS{bandwidth}/1024) ) ."Kb\n" ;
  }

  $buffer = undef ;

  #print "$headers\n" ;

  my ($code) = ( $headers =~ /HTTP[^\s]*[\s]+([\d]+)[\s]+[\w]+?/gsi ) ;
  my ($type) = ( $headers =~ /Content-Type\:?[\s]+([^\n\r]*)[\n\r]?/gsi ) ;
  my ($length) = ( $headers =~ /Content-Length\:?[\s]+([^\n\r]*)[\n\r]?/gsi ) ;
  my ($modf) = ( $headers =~ /Last-Modified\:?[\s]+([^\n\r]*)[\n\r]?/gsi ) ;

  if ($modf =~ /,\s+\d+[\s-]+\w+[\s-]+\d+\s+\d+[:-]\d+[:-]\d+/i) {
    my ($day,$mon,$year,$hour,$min,$sec) = ($modf =~ /,\s+(\d+)[\s-]+(\w+)+[\s-]+(\d+)\s+(\d+)[:-](\d+)[:-](\d+)/i ) ;
    $mon = $MONTHS_EG{lc($mon)} if $mon !~ /^\d+$/ ;
    $modf = timelocal($year,$mon,$day,$hour,$min,$sec) ;
  } else { $modf = '' ;}

  if ( $ACCEPT_GZIP && ($headers =~ /Content-Encoding:\s*gzip/si || $path =~ /\.gz$/i) ) {
    $content = Compress::Zlib::memGunzip($content) ;
  }

  $URLS{$url}{t} = time ;
  $URLS{$url}{status} = $code ;

  $content = '' if $code != 200 ;

  return ( ($head ? () : $content) , $code , $modf , $length , $type ) if wantarray ;

  return if $code != 200 ;

  return $code if $head ;
  return $content ;
}

##############
# NEW_SOCKET #
##############

sub new_socket {
  my ( $host , $port ) = @_ ;

  my $iaddr = inet_aton($host) || return ;
  my $paddr = sockaddr_in($port, $iaddr) || return ;
  my $proto = getprotobyname('tcp') || return ;

  socket(SOCK, PF_INET, SOCK_STREAM, $proto) || return ;

  connect(SOCK, $paddr) || return ;

  my $sel = select(SOCK) ; $|=1 ; select($sel) ;

  return \*SOCK ;
}

#############
# TIMELOCAL #
#############

sub timelocal {
  my ( $year,$mon,$day,$hour,$min,$sec ) = @_ ;

  my $year_0 = (gmtime(1))[5] + 1900 ;

  my ($now_sec,$now_min,$now_hour,$now_mday,$now_mon,$now_year) = gmtime( time ) ;

  if (!$year || $year eq '*' || $year < $year_0) { $year = $now_year ;}

  my $year_bisexto = 0 ;
  if ( is_leap_year($year) ) { $year_bisexto = 1 ;}

  if (!$mon || $mon eq '*') { $mon = $now_mon }
  elsif ($mon < 1 || $mon > 12 ) { return }

  elsif (!$day || $day eq '*') { $day = $now_mday }
  elsif ($day < 1 || $day > 31 ) { return }
  elsif ($mon == 2 && $day > 28) {
    $day = 28 if !check_date($year,$mon,$day) ;
  }
  elsif ($day > check_date($mon) ) { return }

  if    ($hour eq '') { $hour = 0 }
  elsif ($hour eq '*') { $hour = $now_hour }
  elsif ($hour == 24) { $hour = 0 }
  elsif ($hour < 0 || $hour > 24 ) { return }

  if    ($min eq '') { $min = 0 }
  elsif ($min eq '*') { $min = $now_min }
  elsif ($min == 60) { $min = 59 }
  elsif ($min < 0 || $min > 60 ) { return }

  if    ($sec eq '') { $sec = 0 }
  elsif ($sec eq '*') { $sec = $now_sec }
  elsif ($sec == 60) { $sec = 59 }
  elsif ($sec < 0 || $sec > 60 ) { return }

  my $timelocal ;

  my $time_day = 60*60*24 ;
  my $time_year = $time_day * 365 ;

  for my $y ($year_0..($year-1)) {
    $timelocal += $time_year ;
    if ( is_leap_year($y) ) { $timelocal += $time_day ;}
  }

  for my $m (1..($mon-1)) {
    my $month_days = &check_date($m) ;
    $timelocal += $month_days * $time_day ;
  }

  if ($year_bisexto == 1 && $mon > 2) { $timelocal += $time_day ;}

  $timelocal += $time_day * ($day-1) ;

  $timelocal += 60*60 * $hour ;
  $timelocal += 60 * $min ;
  $timelocal += $sec ;

  return $timelocal ;
}

################
# IS_LEAP_YEAR #
################

sub is_leap_year {
  my ( $year ) = @_ ;

  if    ($year == 0) { return 1 ;}
  elsif (($year % 4000) == 0) { return 0 ;}
  elsif (($year % 400) == 0) { return 1 ;}
  elsif (($year % 100) == 0) { return 0 ;}
  elsif (($year % 4) == 0) { return 1 ;}
  return 0 ;
}

##############
# CHECK_DATE #
##############

sub check_date {
  shift if $_[0] !~ /^\d+$/ ;

  my ( $year , $month , $day ) ;

  if ($#_ == 2) { ( $year , $month , $day ) = @_ ;}
  if ($#_ == 1) { ( $month , $day ) = @_ ;}
  if ($#_ == 0) { ( $month ) = @_ ;}

  if ($#_ > 0) {
    if ($year eq '')  { $year = 1970 }
    if ($month eq '') { $month = 1 }
    if ($day eq '')   { $day = 1 }

    my @months_days = @MONTHS_DAYS ;

    if ( is_leap_year($year) ) { $months_days[2] = 29 ;}

    if ($day <= $months_days[$month]) { return 1 ;}
    else { return ;}
  }
  elsif ($#_ == 0) {
    if ($month eq '') { return ; }
    return $MONTHS_DAYS[$month] ;
  }

  return undef ;
}

##################
# IS_FILE_HIDDEN #
##################

sub is_file_hidden {
  my $file = shift ;

  my $data_ref = \$_[0] ;

  if ( -e $file ) {
    my $buffer ;
    open (FLH,$file) ;
    1 while( read(FLH, $buffer , 1024*8 , length($buffer) ) ) ;
    close (FLH) ;
    $data_ref = \$buffer ;
  }

  if ( $$data_ref =~ /(?:^|\r\n?|\n)[ \t]*#[ \t#]*lib:*http[ \t]*=>[ \t]*hidden_?file\s/si ) {
    return 1 ;
  }

  return ;
}

##################
# UNLINK_TMPFILE #
##################

sub unlink_tmpfile {
  close TMPFILE ;

  if ( $_[0] ) {
    open (TMPFILE,">$TMPFILE") ;
    print TMPFILE "\n" ;
    close (TMPFILE) ;
  }

  unlink $TMPFILE ;
  ##print "UNLINK TMPFILE: $TMPFILE [". $INC{'BotCore.pm'} ."]\n" ;
  ##
}

##########
# TMPDIR #
##########

sub tmpdir {

  my @dir_list = (
   @ENV{qw(TMPDIR TEMP TMP)},
   qw(
    C:/temp
    C:/tmp
    SYS:/temp
    SYS:/tmp
    /tmp
    /
   ),
  ) ;

  my $tmpdir ;
  foreach my $dir_list_i ( @dir_list ) {
    next if !$dir_list_i ;
    if ( -d $dir_list_i && -w $dir_list_i && -r $dir_list_i ) {
      $tmpdir = $dir_list_i ;
      last ;
    }
  }

  if ( !$tmpdir && -w '.' ) {
    my @lyb = (a..z,0..9) ;
    my $rand ;
    $rand .= $lyb[ rand(@lyb) ] while length($rand) < 6 ;
    my $dir = "./$rand-tmp" ;
    mkdir($dir , 0777) ;
    $tmpdir = $dir if -d $dir && -w $dir ;
  }

  return $tmpdir ;
}

##########
# MKPATH #
##########

sub mkpath {
  my ( $path ) = @_ ;

  my @path = split(/[\\\/]/ , $path) ;

  my $path ;

  if ( $path[0] =~ /^\w+:$/ ) {
    $path .= shift(@path) . '/' ;
  }

  foreach my $path_i ( @path ) {
    $path .= $path_i . '/' ;
    next if -e $path ;
    mkdir($path , 0777) ;
  }

  return 1 ;
}

##########
# RMTREE #
##########

sub rmtree {
  my ( $path ) = @_ ;

  my @subdirs = scandir($path) ;

  my $main = $subdirs[0] ;

  foreach my $subdirs_i ( reverse @subdirs ) {
    opendir (my $DH, $subdirs_i);

    while (my $filename = readdir $DH) {
      if ($filename ne '.' && $filename ne '..') {
        my $file = "$subdirs_i/$filename" ;
        next if -d $file ;
        unlink($file) ;
      }
    }

    closedir ($DH) ;

    rmdir($subdirs_i) ;
  }

  return 1 ;
}

#######
# END #
#######

sub end {
  unlink_tmpfile(1) ;

  foreach my $TMPDIRS_i ( @TMPDIRS ) {
    print ">> UNLINK> $TMPDIRS_i\n" if $DEBUG ;
    rmtree($TMPDIRS_i) ;
  }

  exit ;
}

sub END { &end ;}

#######
# END #
#######

1;

__END__