##---------------------------------------------------------------------------##
##  File:
##	$Id: mhfile.pl,v 2.13 2010/12/31 21:20:41 ehood Exp $
##  Author:
##      Earl Hood       mhonarc@mhonarc.org
##  Description:
##      File routines for MHonArc
##---------------------------------------------------------------------------##
##    MHonArc -- Internet mail-to-HTML converter
##    Copyright (C) 1997-1999	Earl Hood, mhonarc@mhonarc.org
##
##    This program is free software; you can redistribute it and/or modify
##    it under the terms of the GNU General Public License as published by
##    the Free Software Foundation; either version 2 of the License, or
##    (at your option) any later version.
##
##    This program is distributed in the hope that it will be useful,
##    but WITHOUT ANY WARRANTY; without even the implied warranty of
##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##    GNU General Public License for more details.
##
##    You should have received a copy of the GNU General Public License
##    along with this program; if not, write to the Free Software
##    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
##    02111-1307, USA
##---------------------------------------------------------------------------##

package mhonarc;

use Symbol;
use Fcntl;
use File::Basename;

my $_have_File_Temp;

BEGIN {
    # If File::Temp is installed, we will use it for temporary file
    # generation.
    eval { require File::Temp; };
    $_have_File_Temp = scalar($@) ? 0 : 1;

    # Increase File::Temp safety level if setuid
    if ($_have_File_Temp && $UNIX && $TaintMode) {
        File::Temp->safe_level(File::Temp::MEDIUM);
    }

    # Perl <5.004 did not auto-call srand().
    eval { require 5.004; };
    srand(time ^ ($$ + ($$ << 15))) if scalar($@);
}

# Characters to use for home-grown temporay file generation.  We stick to
# basic alphanumerics to avoid OS-specific filename limitations.
my @TEMP_CHARS = qw(
    A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
    a b c d e f g h i j k l m n o p q r s t u v w x y z
    0 1 2 3 4 5 6 7 8 9 _
);

# Maximum tries to create a temporary file in home-grown implementation
sub TEMP_MAX_TRIES() { 10; }

##---------------------------------------------------------------------------##

sub file_open {
    my ($file)   = shift;
    my ($handle) = gensym;
    my ($gz)     = $file =~ /\.gz$/i;

    if ($gz) {
        cmd_pipe_open($handle, $GzipExe, '-cd', $file);
        return $handle;
    }
    return $handle if open($handle, $file);
    if (-e "$file.gz") {
        cmd_pipe_open($handle, $GzipExe, '-cd', "$file.gz");
        return $handle;
    }
    die qq/ERROR: Failed to open "$file": $!\n/;
}

sub cmd_pipe_open {
    my $handle = shift;
    my @cmd    = @_;

    if (!$UNIX) {
        return $handle if open($handle, join(' ', @cmd, '|'));
        die qq/ERROR: Failed to exec @cmd: $!\n/;
    }
    my $child_pid = open($handle, '-|');
    if ($child_pid) {    # parent
        return $handle;
    } else {             # child
        #open(STDERR, '>&STDOUT');
        exec(@cmd) || die qq/ERROR: Cannot exec "@cmd": $!\n/;
    }
}

sub file_gzip {
    my $file = shift;
    return if ($file =~ /\.gz$/i);
    if (system($GzipExe, $file) != 0) {
        die qq/ERROR: Failed to exec "$GzipExe $file": $! $?\n/;
    }
}

## This function is currently not used anymore
sub file_create {
    my ($file)   = shift;
    my ($gz)     = shift;
    my ($handle) = gensym;

    if ($gz) {
        $file .= ".gz" unless $file =~ /\.gz$/;
        return $handle if open($handle, "| $GzipExe > $file");
        die qq{ERROR: Failed to exec "| $GzipExe > $file": $!\n};
    }
    return $handle if open($handle, "> $file");
    die qq{ERROR: Failed to create "$file": $!\n};
}

sub file_exists {
    (-e $_[0]) || (-e "$_[0].gz");
}

sub file_copy {
    my ($src, $dst) = ($_[0], $_[1]);
    my ($gz) = $src =~ /\.gz$/i;

    if ($gz || (-e "$src.gz")) {
        $src .= ".gz" unless $gz;
        $dst .= ".gz" unless $dst =~ /\.gz$/i;
    }
    &cp($src, $dst);
}

sub file_rename {
    my ($src, $dst) = ($_[0], $_[1]);
    my ($gz) = $src =~ /\.gz$/i;

    if ($gz || (-e "$src.gz")) {
        $src .= ".gz" unless $gz;
        $dst .= ".gz" unless $dst =~ /\.gz$/i;
    }
    if (!rename($src, $dst)) {
        die qq/ERROR: Unable to rename "$src" to "$dst": $!\n/;
    }
    $dst;
}

sub file_remove {
    my ($file) = shift;

    unlink($file);
    unlink("$file.gz");
}

sub file_utime {
    my ($atime) = shift;
    my ($mtime) = shift;
    foreach (@_) {
        utime($atime, $mtime, $_, "$_.gz");
    }
}

sub file_temp {
    my $template = shift;               # Filename template
    my $dir      = shift || $CURDIR;    # Where to write the file
    my $suffix   = shift;               # Required suffix (optional)
    my ($handle, $tmpfile);

MKTEMP: {
        # Do not honor FASTTEMPFILES if a suffix is required, mainly
        # because things like attachment writing will not work with
        # FASTTEMPFILES.
        if ($FastTempFiles && !defined($suffix)) {
            $handle = gensym;
            $tmpfile = join($DIRSEP, $dir, $template . $$);
            if (!sysopen(
                    $handle, $tmpfile, (O_WRONLY | O_EXCL | O_CREAT), 0600
                )
            ) {
                die qq/ERROR: Unable to create temp file "$tmpfile": $!\n/;
            }
            last MKTEMP;
        }

        # Use File::Temp when at all possible
        if ($_have_File_Temp) {
            my @tf_opts = ('DIR' => $dir, 'UNLINK' => 0);
            push(@tf_opts, 'SUFFIX' => $suffix) if $suffix;
            ($handle, $tmpfile) = File::Temp::tempfile($template, @tf_opts);
            last MKTEMP;
        }

        $handle = gensym;
        my ($i);
        for ($i = 0; $i < TEMP_MAX_TRIES; ++$i) {
            ($tmpfile = $template) =~
                s/X/$TEMP_CHARS[int(rand($#TEMP_CHARS))]/ge;
            $tmpfile = join($DIRSEP, $dir, $tmpfile);
            $tmpfile .= $suffix if defined($suffix);
            last
                if sysopen($handle, $tmpfile,
                (O_WRONLY | O_EXCL | O_CREAT), 0600);
        }
        if ($i >= TEMP_MAX_TRIES) {
            die qq/ERROR: Unable to create temp file "$tmpfile": $!\n/;
        }
    }
    ($handle, $tmpfile);
}

sub file_chmod {
    my $file = shift;
    my $perm = shift || $FilePermsOct;
    ## Capture any die's in case chmod not supported.
    eval {
        if (chmod(($perm & ~umask), $file) < 1) {
            warn qq/Warning: Unable to change "$file" permissions to "/,
                sprintf('%o' . $perm),
                qq/": $!\n/;
        }
    };
}

##---------------------------------------------------------------------------##

sub dir_create {
    my $path = shift;
    my $perms = shift || 0777;

    if (!$UNIX) {
        ## Non-Unix OS's do not have symlinks
        return if (-e $path);
        if (!mkdir($path, $perms)) {
            die qq/ERROR: Unable to create "$path": $!\n/;
        }
        return;
    }

    ## Check if $path is a symlink
    if (-l $path) {
        if ($FollowSymlinks) {
            # Symlinks allowed, so we check if symlink is to a directory
            die qq/ERROR: "$path" is not a directory: $!\n/ if !(-d $path);
            return;
        }
        # symlink, try to delete
        warn qq/Warning: "$path" is a symlink, will try to replace...\n/;
        if (!unlink($path)) {
            die qq/ERROR: "$path" is a symlink, unable to remove: $!\n/;
        }
    } elsif (-e $path) {
        die qq/ERROR: "$path" is not a directory: $!\n/ if !(-d _);
        # already exists, nothing to do
        return;
    }

    my $dirname = dirname($path);
    my @info    = stat($dirname);
    if ($info[2] & Fcntl::S_IWGRP || $info[2] & Fcntl::S_IWOTH) {
        my ($i, $errstr, $tmpdir);
        for ($i = 0; $i < TEMP_MAX_TRIES; ++$i) {
            $tmpdir = dir_temp('dirXXXXXXXXXX', $dirname);
            if (!rename($tmpdir, $path)) {
                $errstr = "$!";
                rmdir($tmpdir);
                if (-l $path) {
                    # hmmmm, somone trying to so something malicious?
                    warn qq/Warning: Possible symlink attack attempted with /,
                        qq/"$path"\n/;
                    die
                        qq/ERROR: "$path" is a symlink, unable to remove: $!\n/
                        unless unlink $path;
                } elsif (-d $path) {
                    # somebody snuck in and created it
                    return;
                } elsif (-e _) {
                    die qq/ERROR: "$path" exists, but it did not before, /,
                        qq/and it is not a directory!\n/;
                }
            } else {
                last;
            }
        }
        if ($i >= TEMP_MAX_TRIES) {
            die qq/ERROR: Unable to rename "$tmpdir" to "$path": $errstr\n/;
        }

    } else {
        if (!mkdir($path, $perms)) {
            die qq/ERROR: Unable to create "$path": $!\n/;
        }
    }
    chmod(($perms & ~umask), $path);
}

sub dir_temp {
    my $template = shift;
    my $dir = shift || $CURDIR;
    my ($tmpdir);

MKTEMP: {
        if ($_have_File_Temp) {
            $tmpdir =
                File::Temp::tempdir($template, 'DIR' => $dir, 'CLEANUP' => 0);
            last MKTEMP;
        }

        my ($i);
        for ($i = 0; $i < TEMP_MAX_TRIES; ++$i) {
            ($tmpdir = $template) =~
                s/X/$TEMP_CHARS[int(rand($#TEMP_CHARS))]/ge;
            $tmpdir = join($DIRSEP, $dir, $tmpdir);
            last if mkdir $tmpdir, 0700;
        }
        if ($i >= TEMP_MAX_TRIES) {
            die qq/ERROR: Unable to create temp dir "$tmpdir": $!\n/;
        }
    }
    $tmpdir;
}

sub dir_remove {
    my ($file) = shift;

    if (-d $file) {
        local (*DIR);
        local ($_);
        if (!opendir(DIR, $file)) {
            warn qq{Warning: Unable to open "$file"\n};
            return 0;
        }
        my @files = grep(!/^(\.|\..)$/i, readdir(DIR));
        closedir(DIR);
        foreach (@files) {
            &dir_remove($file . $mhonarc::DIRSEP . $_);
        }
        if (!rmdir($file)) {
            warn qq{Warning: Unable to remove "$file": $!\n};
            return 0;
        }

    } else {
        if (!unlink($file)) {
            warn qq{Warning: Unable to delete "$file": $!\n};
            return 0;
        }
    }
    1;
}

##---------------------------------------------------------------------------##

sub rand_string {
    my $template = shift;
    $template =~ s/X/$TEMP_CHARS[int(rand($#TEMP_CHARS))]/ge;
    $template;
}

##---------------------------------------------------------------------------##
1;
