view release on metacpan or  search on metacpan

lib/Test/MockFile/FileHandle.pm  view on Meta::CPAN

    my $bytes = $self->_write_bytes($output);
    $self->_update_write_times() if $bytes;

    return 1;
}

=head2 PRINTF

This method will be triggered every time the tied handle is printed to
with the printf() function. Beyond its self reference it also expects
the format and list that was passed to the printf function.

Per L<perlfunc/printf>, C<printf> does B<not> append C<$\> (the output
record separator), unlike C<print>. We therefore write directly via
C<_write_bytes> instead of delegating to C<PRINT>.

=cut

sub PRINTF {
    my $self   = shift;
    my $format = shift;

    if ( !$self->{'write'} ) {
        $! = EBADF;
        return;
    }

    my $data = $self->{'data'} or do {
        $! = EBADF;
        return 0;
    };

    my $bytes = $self->_write_bytes( sprintf( $format, @_ ) );
    $self->_update_write_times() if $bytes;

    return 1;
}

=head2 WRITE

This method will be called when the handle is written to via the
syswrite function.

Arguments passed are:C<( $self, $buf, $len, $offset )>

This is one of the more complicated functions to mimic properly because
$len and $offset have to be taken into account. Reviewing how syswrite
works reveals there are all sorts of weird corner cases.

=cut

sub WRITE {
    my ( $self, $buf, $len, $offset ) = @_;

    if ( !$self->{'write'} ) {
        $! = EBADF;
        return 0;
    }

    unless ( $len =~ m/^-?[0-9.]+$/ ) {
        CORE::warn(qq{Argument "$len" isn't numeric in syswrite at @{[ join ' line ', (caller)[1,2] ]}.\n});
        $! = EINVAL;
        return 0;
    }

    $len = int($len);    # Perl seems to do this to floats.

    if ( $len < 0 ) {
        CORE::warn(qq{Negative length at @{[ join ' line ', (caller)[1,2] ]}.\n});
        $! = EINVAL;
        return 0;
    }

    my $strlen = length($buf);
    $offset //= 0;

    if ( $offset < 0 ) {
        $offset = $strlen + $offset;
    }

    if ( $offset < 0 || $offset > $strlen ) {
        CORE::warn(qq{Offset outside string at @{[ join ' line ', (caller)[1,2] ]}.\n});
        $! = EINVAL;
        return 0;
    }

    # Write directly — syswrite must NOT inherit $, or $\ from PRINT.
    # Per perlapi: if len exceeds available data after offset, writes
    # only what is available (substr handles this naturally).
    my $bytes = $self->_write_bytes( substr( $buf, $offset, $len ) );
    $self->_update_write_times() if $bytes;
    return $bytes;
}

=head2 READLINE

This method is called when the handle is read via <HANDLE> or readline
HANDLE.

Based on the numeric location we are in the file (tell), we read until
the EOF separator (C<$/>) is seen. tell is updated after the line is
read. undef is returned if tell is already at EOF.

=cut

sub _READLINE_ONE_LINE {
    my ($self) = @_;

    my $data = $self->{'data'} or return undef;
    my $contents = $data->{'contents'};
    my $len      = length($contents);
    my $tell     = $self->{'tell'};

    # Slurp mode: $/ = undef — return everything from tell to end
    if ( !defined $/ ) {
        return undef if $tell >= $len;
        $self->{'tell'} = $len;
        return substr( $contents, $tell );
    }

    # Fixed-record mode: $/ = \N — read exactly N bytes
    if ( ref $/ ) {
        my $reclen = ${ $/ } + 0;
        return undef if $tell >= $len;
        my $remaining = $len - $tell;
        my $read_len  = $reclen < $remaining ? $reclen : $remaining;
        $self->{'tell'} = $tell + $read_len;
        return substr( $contents, $tell, $read_len );
    }

    # Paragraph mode: $/ = '' — read paragraphs separated by blank lines
    if ( $/ eq '' ) {
        my $pos = $tell;

        # Skip leading newlines
        while ( $pos < $len && substr( $contents, $pos, 1 ) eq "\n" ) {
            $pos++;
        }
        return undef if $pos >= $len;

        my $start    = $pos;
        my $boundary = index( $contents, "\n\n", $pos );

lib/Test/MockFile/FileHandle.pm  view on Meta::CPAN

        while ( defined $line ) {
            push @all, $line;
            $line = _READLINE_ONE_LINE($self);
        }
        $self->_update_read_time() if @all;
        return @all;
    }

    my $line = _READLINE_ONE_LINE($self);
    $self->_update_read_time() if defined $line;
    return $line;
}

=head2 GETC

This method will be called when the getc function is called. It reads 1
character out of contents and adds 1 to tell. The character is
returned. Returns undef at EOF.

=cut

sub GETC {
    my ($self) = @_;

    if ( !$self->{'read'} ) {
        my $path = $self->{'file'} // 'unknown';
        CORE::warn("Filehandle $path opened only for output");
        return undef;
    }

    return undef if $self->EOF;

    my $data = $self->{'data'} or return undef;
    my $char = substr( $data->{'contents'}, $self->{'tell'}, 1 );
    $self->{'tell'}++;
    $self->_update_read_time();

    return $char;
}

=head2 READ

Arguments passed are:C<( $self, $file_handle, $len, $offset )>

This method will be called when the handle is read from via the read or
sysread functions. Based on C<$offset> and C<$len>, it's possible to
end up with some really weird strings with null bytes in them.

=cut

sub READ {
    my ( $self, undef, $len, $offset ) = @_;

    if ( !$self->{'read'} ) {
        $! = EBADF;
        return undef;
    }

    # Validate $len the same way WRITE does — match real sysread behavior.
    unless ( $len =~ m/^-?[0-9.]+$/ ) {
        CORE::warn(qq{Argument "$len" isn't numeric in sysread at @{[ join ' line ', (caller)[1,2] ]}.\n});
        $! = EINVAL;
        return undef;
    }

    $len = int($len);

    if ( $len < 0 ) {
        CORE::warn(qq{Negative length at @{[ join ' line ', (caller)[1,2] ]}.\n});
        $! = EINVAL;
        return undef;
    }

    # If the caller's buffer is undef, we need to make it a string of 0 length to start out with.
    $_[1] = '' if !defined $_[1];

    my $data = $self->{'data'} or do {
        $! = EBADF;
        return 0;
    };

    my $contents_len = length $data->{'contents'};
    my $buf_len      = length $_[1];

    $offset //= 0;
    if ( $offset > $buf_len ) {
        $_[1] .= "\0" x ( $offset - $buf_len );
    }
    my $tell = $self->{'tell'};

    # If tell is at or past the end of contents, nothing to read (EOF)
    return 0 if $tell >= $contents_len;

    my $read_len = ( $contents_len - $tell < $len ) ? $contents_len - $tell : $len;

    substr( $_[1], $offset ) = substr( $data->{'contents'}, $tell, $read_len );

    $self->{'tell'} += $read_len;
    $self->_update_read_time() if $read_len;

    return $read_len;
}

=head2 CLOSE

This method will be called when the handle is closed via the close
function. The object is untied and the file contents (weak reference)
is removed. Further calls to this object should fail.

=cut

sub CLOSE {
    my ($self) = @_;

    # Remove this specific handle from the mock's fhs list.
    # Each handle has its own tied object, so we match by tied identity.
    # Try through the weak data ref first, then fall back to the global hash.
    my $mock = $self->{'data'};
    if ( !$mock && $self->{'file'} ) {
        $mock = $files_being_mocked->{ $self->{'file'} };
    }

    if ( $mock && $mock->{'fhs'} ) {
        @{ $mock->{'fhs'} } = grep {
            defined $_ && ( !ref $_ || ( tied( *{$_} ) || 0 ) != $self )
        } @{ $mock->{'fhs'} };
    }

    return 1;