package Text::Template::Simple::IO;
use strict;
use vars qw($VERSION);
use File::Spec;
use Text::Template::Simple::Constants qw(:all);
use Text::Template::Simple::Util qw( DEBUG LOG ishref binary_mode fatal );
use constant MY_IO_LAYER      => 0;
use constant MY_INCLUDE_PATHS => 1;
use constant MY_TAINT_MODE    => 2;

$VERSION = '0.81';

sub new {
   my $class = shift;
   my $layer = shift;
   my $paths = shift;
   my $tmode = shift;
   my $self  = [ undef, undef, undef ];
   bless $self, $class;
   $self->[MY_IO_LAYER]      = $layer if defined $layer;
   $self->[MY_INCLUDE_PATHS] = [ @{ $paths } ] if $paths; # copy
   $self->[MY_TAINT_MODE]    = $tmode;
   $self;
}

sub validate {
   my $self = shift;
   my $type = shift || fatal('tts.io.validate.type');
   my $path = shift || fatal('tts.io.validate.path');

   if ( $type eq 'dir' ) {
      require File::Spec;
      $path = File::Spec->canonpath( $path );
      my $wdir;

      if ( IS_WINDOWS ) {
         $wdir = Win32::GetFullPathName( $path );
         if( Win32::GetLastError() ) {
            LOG( FAIL => "Win32::GetFullPathName( $path ): $^E" ) if DEBUG();
            $wdir = ''; # die "Win32::GetFullPathName: $^E";
         }
         else {
            my $ok = -e $wdir && -d _;
            $wdir  = '' if not $ok;
         }
      }

      $path = $wdir if $wdir;
      my $ok = -e $path && -d _;
      return if not $ok;
      return $path;
   }

   fatal('tts.io.validate.file');
}

sub layer {
   return if ! NEW_PERL;
   my $self   = shift;
   my $fh     = shift || fatal('tts.io.layer.fh');
   my $layer  = $self->[MY_IO_LAYER];
   binary_mode( $fh, $layer ) if $layer;
   return;
}

sub slurp {
   require IO::File;
   require Fcntl;
   my $self = shift;
   my $file = shift;
   my($fh, $seek);
   LOG(IO_SLURP => $file) if DEBUG();

   # perl 5.5.3 compat: we need to check if it's a ref first
   if ( ref $file && fileno $file ) {
      $fh   = $file;
      $seek = 1;
   }
   else {
      $fh = IO::File->new;
      $fh->open($file, 'r') or fatal('tts.io.slurp.open', $file, $!);
   }

   flock $fh,    Fcntl::LOCK_SH()  if IS_FLOCK;
   seek  $fh, 0, Fcntl::SEEK_SET() if IS_FLOCK && $seek;
   $self->layer( $fh ) if ! $seek; # apply the layer only if we opened this

   if ( $self->_handle_looks_safe( $fh ) ) {
      require IO::Handle;
      my $rv = IO::Handle::untaint( $fh );
      fatal('tts.io.slurp.taint') if $rv != 0;
   }

   my $tmp = do { local $/; my $rv = <$fh>; $rv };
   flock $fh, Fcntl::LOCK_UN() if IS_FLOCK;
   close $fh if ! $seek; # close only if we opened this
   return $tmp;
}

sub _handle_looks_safe {
   # Cargo Culting: original taint checking code was taken from "The Camel"
   my $self = shift;
   my $fh   = shift;
   fatal('tts.io.hls.invalid') if ! $fh || ! fileno $fh;

   require File::stat;
   my $i = File::stat::stat( $fh );
   return if ! $i;

   my $tmode = $self->[MY_TAINT_MODE];

   # owner neither superuser nor "me", whose
   # real uid is in the $< variable
   return if $i->uid != 0 && $i->uid != $<;

   # Check whether group or other can write file.
   # Read check is disabled by default
   # Mode is always 0666 on Windows, so all tests below are disabled on Windows
   # unless you force them to run
   LOG( FILE_MODE => sprintf "%04o", $i->mode & 07777) if DEBUG;

   my $bypass   = IS_WINDOWS && ! ( $tmode & TAINT_CHECK_WINDOWS ) ? 1 : 0;
   my $go_write = $bypass ? 0 : $i->mode & 022;
   my $go_read  = ! $bypass && ( $tmode & TAINT_CHECK_FH_READ )
                ? $i->mode & 066
                : 0;

   LOG( TAINT => "tmode:$tmode; bypass:$bypass; "
                ."go_write:$go_write; go_read:$go_read") if DEBUG;

   return if $go_write || $go_read;
   return 1;
}

sub is_file {
   # safer than a simple "-e"
   my $self = shift;
   my $file = shift || return;
   return $self->_looks_like_file( $file ) && ! -d $file;
}

sub is_dir {
   # safer than a simple "-d"
   my $self = shift;
   my $file = shift || return;
   return $self->_looks_like_file( $file ) && -d $file;
}

sub file_exists {
   my $self = shift;
   my $file = shift;

   return $file if $self->is_file( $file );

   foreach my $path ( @{ $self->[MY_INCLUDE_PATHS] } ) {
      my $test = File::Spec->catfile( $path, $file );
      return $test if $self->is_file( $test );
   }

   return; # fail!
}

sub _looks_like_file {
   my $self = shift;
   my $file = shift || return;
   return     ref $file               ? 0
         :        $file =~ RE_NONFILE ? 0
         : length $file >= 255        ? 0
         :     -e $file               ? 1
         :                              0
         ;
}

sub DESTROY {
   my $self = shift;
   LOG( DESTROY => ref $self ) if DEBUG();
   return;
}

1;

__END__

=head1 NAME

Text::Template::Simple::IO - I/O methods

=head1 SYNOPSIS

TODO

=head1 DESCRIPTION

This document describes version C<0.81> of C<Text::Template::Simple::IO>
released on C<13 September 2009>.

TODO

=head1 METHODS

=head2 new IO_LAYER

Constructor. Accepts an I/O layer name as the parameter.

=head2 layer FH

Sets the I/O layer of the supplied filehandle if there is a layer and perl
version is greater or equal to C<5.8>.

=head2 slurp FILE_PATH

Returns the contents of the supplied file as a string.

=head2 validate TYPE, PATH

C<TYPE> can either be C<dir> or C<file>. Returns the corrected path if
it is valid, C<undef> otherwise.

=head2 is_dir THING

Test if C<THING> is a directory.

=head2 is_file THING

Test if C<THING> is a file.

=head2 file_exists THING

Test if C<THING> is a file. This method also searches all the C<include paths>
and returns the full path to the file if it exists.

=head1 AUTHOR

Burak Gursoy <burak@cpan.org>.

=head1 COPYRIGHT

Copyright 2004 - 2009 Burak Gursoy. All rights reserved.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify 
it under the same terms as Perl itself, either Perl version 5.10.0 or, 
at your option, any later version of Perl 5 you may have available.

=cut