The Perl Advent Calendar needs more articles for 2022. Submit your idea today!
# Copyright (c) 2018, cPanel, LLC.
# All rights reserved.
# http://cpanel.net
#
# This is free software; you can redistribute it and/or modify it under the
# same terms as Perl itself. See L<perlartistic>.

package Test::MockFile::FileHandle;

use strict;
use warnings;
use Errno qw/EBADF/;
use Scalar::Util ();

my $files_being_mocked;
{
    no warnings 'once';
    $files_being_mocked = \%Test::MockFile::files_being_mocked;
}

=head1 NAME

Test::MockFile::FileHandle - Provides a class for L<Test::MockFile> to tie to on B<open> or B<sysopen>.

=head1 VERSION

Version 0.013

=cut

=head1 SYNOPSIS

This is a helper class for L<Test::MockFile>. It leverages data in the Test::MockFile namespace but
lives in its own package since it is the class that file handles are tied to when created in L<Test::MockFile>

    use Test::MockFile::FileHandle;
    tie *{ $_[0] }, 'Test::MockFile::FileHandle', $abs_path, $rw;


=head1 EXPORT

No exports are provided by this module.

=head1 SUBROUTINES/METHODS

=head2 TIEHANDLE

Args: ($class, $file, $mode)

Returns a blessed object for L<Test::MockFile> to tie against. There are no error conditions handled here.

One of the object variables tracked here is a pointer to the file contents in C<%Test::MockFile::files_being_mocked>.
In order to allow MockFiles to be DESTROYED when they go out of scope, we have to weaken this pointer.

See L<Test::MockFile> for more info.

=cut

sub TIEHANDLE {
    my ( $class, $file, $mode ) = @_;

    length $file or die("No file name passed!");

    my $self = bless {
        'file'  => $file,
        'data'  => $files_being_mocked->{$file},
        'tell'  => 0,
        'read'  => $mode =~ m/r/ ? 1 : 0,
        'write' => $mode =~ m/w/ ? 1 : 0,
    }, $class;

    # This ref count can't hold the object from getting released.
    Scalar::Util::weaken( $self->{'data'} );

    return $self;
}

=head2 PRINT

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

We append to C<$Test::MockFile::files_being_mocked{$file}->{'contents'}> with what was sent. If the file
handle wasn't opened in a read mode, then this call with throw EBADF via $!

=cut

sub PRINT {
    my ( $self, @list ) = @_;

    if ( !$self->{'write'} ) {

        # Filehandle $fh opened only for input at t/readline.t line 27, <$fh> line 2.
        # https://github.com/CpanelInc/Test-MockFile/issues/1
        CORE::warn("Filehandle ???? opened only for input at ???? line ???, <???> line ???.");
        $! = EBADF;
        return;
    }

    my $starting_bytes = length $self->{'data'}->{'contents'};
    foreach my $line (@list) {
        next if !defined $line;
        $self->{'data'}->{'contents'} .= $line;
    }

    return length( $self->{'data'}->{'contents'} ) - $starting_bytes;
}

=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.

We use sprintf to format the output and then it is sent to L<PRINT>

=cut

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

    return $self->PRINT( sprintf( $format, @_ ) );
}

=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 ) = @_;

    unless ( $len =~ m/^-?[0-9.]+$/ ) {
        $! = qq{Argument "$len" isn't numeric in syswrite at ??};
        return 0;
    }

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

    if ( $len < 0 ) {
        $! = qq{Negative length at ???};
        return 0;
    }

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

    if ( $strlen - $offset < abs($len) ) {
        $! = q{Offset outside string at ???.};
        return 0;
    }

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

    return $self->PRINT( substr( $buf, $offset, $len ) );
}

=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 {
    my ($self) = @_;

    my $tell     = $self->{'tell'};
    my $rs       = $/ // '';
    my $new_tell = index( $self->{'data'}->{'contents'}, $rs, $tell ) + length($rs);

    if ( $new_tell == 0 ) {
        $new_tell = length( $self->{'data'}->{'contents'} );
    }
    return undef if ( $new_tell == $tell );    # EOF

    my $str = substr( $self->{'data'}->{'contents'}, $tell, $new_tell - $tell );
    $self->{'tell'} = $new_tell;
    return $str;
}

=head2 GETC

B<UNIMPLEMENTED>: Open a ticket in L<github|https://github.com/cpanelinc/Test-MockFile/issues> if you need this feature.

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.

=cut

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

    die('Unimplemented');
}

=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 the caller's buffer is undef, we need to make it a string of 0 length to start out with.
    $_[1] = '' if !defined $_[1];    # TODO: test me

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

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

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

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

    $self->{'tell'} += $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) = @_;

    delete $self->{'data'}->{'fh'};
    untie $self;

    return 1;
}

=head2 UNTIE

As with the other types of ties, this method will be called when untie happens.
It may be appropriate to "auto CLOSE" when this occurs. See The untie Gotcha below.

What's strange about the development of this class is that we were unable to determine how to trigger this call.
At the moment, the call is just redirected to CLOSE.

=cut

sub UNTIE {
    my $self = shift;

    #print STDERR "# UNTIE!\n";
    return $self->CLOSE;
}

=head2 DESTROY

As with the other types of ties, this method will be called when the tied handle is about
to be destroyed. This is useful for debugging and possibly cleaning up.

At the moment, the call is just redirected to CLOSE.

=cut

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

    return $self->CLOSE;
}

=head2 EOF

This method will be called when the eof function is called.
Based on C<$self-E<gt>{'tell'}>, we determine if we're at EOF.

=cut

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

    if ( !$self->{'read'} ) {
        CORE::warn(q{Filehandle STDOUT opened only for output});
    }
    return $self->{'tell'} == length $self->{'data'}->{'contents'};
}

=head2 BINMODE

B<UNIMPLEMENTED>: Open a ticket in L<github|https://github.com/cpanelinc/Test-MockFile/issues> if you need this feature.

No L<perldoc documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles> exists on this method.

=cut

sub BINMODE {
    my ($self) = @_;
    die('Unimplemented');
}

=head2 OPEN

B<UNIMPLEMENTED>: Open a ticket in L<github|https://github.com/cpanelinc/Test-MockFile/issues> if you need this feature.

No L<perldoc documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles> exists on this method.

=cut

sub OPEN {
    my ($self) = @_;
    die('Unimplemented');
}

=head2 FILENO

B<UNIMPLEMENTED>: Open a ticket in L<github|https://github.com/cpanelinc/Test-MockFile/issues> if you need this feature.

No L<perldoc documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles> exists on this method.

=cut

sub FILENO {
    my ($self) = @_;
    die('Unimplemented');
}

=head2 SEEK

Arguments passed are:C<( $self, $pos, $whence )>

Moves the location of our current tell location. 

B<$whence is UNIMPLEMENTED>: Open a ticket in L<github|https://github.com/cpanelinc/Test-MockFile/issues> if you need this feature.

No L<perldoc documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles> exists on this method.

=cut

sub SEEK {
    my ( $self, $pos, $whence ) = @_;

    if ($whence) {
        die('Unimplemented');
    }
    my $file_size = length $self->{'data'}->{'contents'};
    return if $file_size < $pos;

    $self->{'tell'} = $pos;

    return 1;
}

=head2 TELL

Returns the numeric location we are in the file. The C<TELL> tells us where we are in the file contents.

No L<perldoc documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles> exists on this method.

=cut

sub TELL {
    my ($self) = @_;
    return $self->{'tell'};
}

1;