File Coverage

blib/lib/PAGI/Request/Upload.pm

Criterion	Covered	Total	%
statement	81	90	90.0
branch	20	36	55.5
condition	6	16	37.5
subroutine	21	21	100.0
pod	13	14	92.8
total	141	177	79.6

package PAGI::Request::Upload;
$PAGI::Request::Upload::VERSION = '0.002000';
use strict;
use warnings;

use File::Basename qw(fileparse);
use File::Copy qw(move);
use File::Spec;
use Carp qw(croak);


# Constructor
sub new {
    my ($class, %args) = @_;
    my $self = bless {
        field_name   => $args{field_name}   // croak("field_name is required"),
        filename     => $args{filename}     // '',
        content_type => $args{content_type} // 'application/octet-stream',
        data         => $args{data},        # in-memory content
        temp_path    => $args{temp_path},   # on-disk path
        size         => $args{size},
        _cleaned_up  => 0,
    }, $class;

    # Calculate size if not provided
    if (!defined $self->{size}) {
        if (defined $self->{data}) {
            $self->{size} = length($self->{data});
        } elsif (defined $self->{temp_path} && -f $self->{temp_path}) {
            $self->{size} = -s $self->{temp_path};
        } else {
            $self->{size} = 0;
        }
    }

    return $self;
}

# Accessors
sub field_name   { my ($self) = @_; $self->{field_name} }
sub filename     { my ($self) = @_; $self->{filename} }
sub content_type { my ($self) = @_; $self->{content_type} }
sub size         { my ($self) = @_; $self->{size} }
sub temp_path    { my ($self) = @_; $self->{temp_path} }

# Basename - strips Windows and Unix paths
sub basename {
    my ($self) = @_;
    my $filename = $self->{filename};
    return '' unless $filename;

    # Strip Windows paths (C:\Users\... or \\server\share\...)
    $filename =~ s/.*[\\\/]//;

    return $filename;
}

# Predicates
sub is_empty {
    my ($self) = @_;
    return $self->{size} == 0;
}

sub is_in_memory {
    my ($self) = @_;
    return defined($self->{data});
}

sub is_on_disk {
    my ($self) = @_;
    return defined($self->{temp_path});
}

# Content access - slurp
sub slurp {
    my ($self) = @_;
    if ($self->is_in_memory) {
        return $self->{data};
    } elsif ($self->is_on_disk) {
        open my $fh, '<:raw', $self->{temp_path}
            or croak("Cannot read $self->{temp_path}: $!");
        my $content = do { local $/; <$fh> };
        close $fh;
        return $content;
    }
    return '';
}

# Content access - filehandle
sub fh {
    my ($self) = @_;
    if ($self->is_in_memory) {
        open my $fh, '<', \$self->{data}
            or croak("Cannot create filehandle from memory: $!");
        return $fh;
    } elsif ($self->is_on_disk) {
        open my $fh, '<:raw', $self->{temp_path}
            or croak("Cannot open $self->{temp_path}: $!");
        return $fh;
    }
    croak("No content available");
}

# Move upload to destination (BLOCKING - performs synchronous file I/O)
sub move_to {
    my ($self, $destination) = @_;

    # Ensure destination directory exists
    my ($name, $dir) = fileparse($destination);
    if ($dir && !-d $dir) {
        require File::Path;
        File::Path::make_path($dir);
    }

    if ($self->is_in_memory) {
        # Write data to destination (blocking I/O)
        open my $fh, '>:raw', $destination
            or croak("Cannot open $destination for writing: $!");
        print $fh $self->{data};
        close $fh;

        # Mark as cleaned up so destructor doesn't touch the saved file
        delete $self->{data};
        $self->{_cleaned_up} = 1;

        return $self;
    } elsif ($self->is_on_disk) {
        # Use File::Copy::move (typically a rename, very fast)
        move($self->{temp_path}, $destination)
            or croak("Cannot move to $destination: $!");

        # Mark as cleaned up so destructor doesn't touch the saved file
        delete $self->{temp_path};
        $self->{_cleaned_up} = 1;

        return $self;
    }

    croak("No content to move");
}

# Discard the upload
sub discard {
    my ($self) = @_;
    return if $self->{_cleaned_up};

    if ($self->is_on_disk && -f $self->{temp_path}) {
        unlink $self->{temp_path};
    }

    delete $self->{data};
    delete $self->{temp_path};
    $self->{_cleaned_up} = 1;
}

# Destructor - cleanup temp files
sub DESTROY {
    my ($self) = @_;
    $self->discard;
}

1;

__END__