package Win32::API;

use 5.006002;

use strict;
use warnings;

use Carp;
use Time::Local ();

our $VERSION = '0.013';

my %mock = (
    KERNEL32	=> {
	FileTimeToLocalFileTime => {
	    arg		=> [ qw{ P P } ],
	    ret		=> 'I',
	    code	=> sub {
		$_[1] = $_[0];
		return 1;
	    },
	},
	FileTimeToSystemTime	=> {
	    arg		=> [ qw{ P P } ],
	    ret		=> 'I',
	    code	=> sub {
		my ( undef, $ft ) = unpack 'LL', $_[0];
		my @local = localtime $ft;
		@local = reverse @local[0..5];
		$local[0] += 1900;
		$local[1] += 1;
		splice @local, 2, 0, 0;
		push @local, 0;
		@_[1] = pack 'ssssssss', @local;
		return 1;
	    },
	},
	GetFileTime	=> {
	    arg		=> [ qw{ N P P P } ],
	    ret		=> 'I',
	    code	=> sub {
		my ( $fh ) = @_;
		my ( undef, undef, undef, undef, undef, undef, undef,
		    undef, $atime, $mtime, $ctime ) = stat $fh
		    or return;
		$_[1] = pack 'LL', 0, $ctime;
		$_[2] = pack 'LL', 0, $atime;
		$_[3] = pack 'LL', 0, $mtime;
		return 1;
	    },
	},
	LocalFileTimeToFileTime	=> {
	    arg		=> [ qw{ P P } ],
	    ret		=> 'I',
	    code	=> sub {
		$_[1] = $_[0];
		return 1;
	    },
	},
	SetFileTime	=> {
	    arg		=> [ qw{ N P P P } ],
	    ret		=> 'I',
	    code	=> sub {
		my ( $fh, $atime, $mtime ) = @_;
		( undef, $atime ) = unpack 'LL', $atime;
		( undef, $mtime ) = unpack 'LL', $mtime;
		return utime $atime, $mtime, $fh;
	    },
	},
	SystemTimeToFileTime	=> {
	    arg		=> [ qw{ P P } ],
	    ret		=> 'I',
	    code	=> sub {
		my @localtime = unpack 'sssssss', $_[0];
		splice @localtime, 2, 1;
		$localtime[0] -= 1900;
		$localtime[1] -= 1;
		my $local = Time::Local::timelocal( reverse @localtime );
		$_[1] = pack 'LL', 0, $local;
		return 1;
	    },
	},
    },
);

foreach my $dll ( keys %mock ) {
    foreach my $name ( keys %{ $mock{$dll} } ) {
	$mock{$dll}{$name}{name} = $name;
    }
}

sub new {
    my ( $class, $lib, $sub, $arg, $ret ) = @_;
#   my $mock = join '__', '_mock', $lib, $sub;
    $mock{$lib}
	or croak "No mock code available for $lib.dll";
    my $info = $mock{$lib}{$sub}
	or croak "No mock code available for $lib $sub()";
    my $arg_got = join ' ', @{ $arg };
    my $arg_want = join ' ', @{ $info->{arg} };
    $arg_got eq $arg_want
	or croak "Incorrect arguments '$arg_got' for $lib $sub()";
    $ret = $info->{ret}
	or croak "Incorrect return value '$ret' for $lib $sub()";
    return bless $info, ref $class || $class;
}

# Note that in pretty much ALL the following, the Microsoft calling
# convention requires that arguments be modified, and that those
# modifications be visible to the caller. For this reason we must not
# unpack the argument list, at least not completely.
sub Call {
    my $self = shift;
    $self->_validate( @_ );
    return $self->{code}->( @_ );
}

{
    my @trace;

    sub __mock_add_to_trace {
	my @args = @_;
	push @trace, \@args;
	return;
    }

    sub __mock_clear_trace {
	@trace = ();
	return;
    }

    sub __mock_get_trace {
	return \@trace;
    }

}

{
#   my $size_quad = _size( pack 'LL', 0, 0 );

    my %valid = (
	N	=> sub {
	    return;
	},
	P	=> sub {
	    # I used to validate this as being the same size as a
	    # quadword, but this is wrong, because the real Win32::API
	    # takes this to mean "make a pointer to the passed value,"
	    # which can be any size. It still needs to be preallocated,
	    # though.
	    return;
	},
    );

    sub _validate {
	my ( $self, @arg ) = @_;
	@arg == @{ $self->{arg} }
	    or croak 'Wrong number of arguments for $self->{name}()';
	my $inx = 0;
	foreach ( @arg ) {
	    my $spec = $self->{arg}[$inx];
	    my $code = $valid{$spec}
		or croak "No validation coded for '$spec'";
	    $code->( $self, $inx, $_ );
	} continue {
	    $inx++;
	}
	__mock_add_to_trace( $self->{name}, @arg );
	return;
    }
}

sub _size {
    my ( $arg ) = @_;
    my @c = unpack 'c*', $arg;
    return scalar @c;
}

1;

__END__

=head1 NAME

mock::Win32::API - Mock interface to Windows dlls.

=head1 SYNOPSIS

 use lib qw{ inc/mock };
 use Win32::API;
 
 my $lft2ft = Win32::API->new(
     KERNEL32 => 'LocalFileTimeToFileTime',
     [ qw{ P P } ], 'I' );
 my $lft = windows_style_local_file_time();
 my $ft = $lft;	# Just to get space allocated
 $lft2ft->Call( $lft, $ft )
     or die "Call failed";

=head1 DESCRIPTION

This module is private to this distribution. It can be changed or
retracted without notice. Documentation is for the benefit of the
author.

This Perl class mocks the L<Win32::API|Win32::API> module and whatever
system calls are needed by this package.

=head1 METHODS

This class supports the following methods, which are private to this
package:

=head2 new

 my $lft2ft = Win32::API->new(
     KERNEL32 => 'LocalFileTimeToFileTime',
     [ qw{ P P } ], 'I' );

This static method instantiates the object. The arguments are the name
of the DLL being mapped, the name of the function in that DLL, a
reference to an array encoding the types of the arguments to that
function, and the type of the return value. There must be a mocked
version of the function already coded in this module. The arguments will
be checked.

=head2 Call

 $lft2ft->Call( $lft, $ft )
     or die "Call failed";

This method invokes the mocked function. Just as in the case of the real
L<Win32::API|Win32::API>, all output arguments must already have space
preallocated.

=head1 SEE ALSO

L<Win32::API|Win32::API> (the real one).

=head1 SUPPORT

Support is by the author. Please file bug reports at
L<https://github.com/trwyant/perl-Win32API-File-Time/issues> or in
electronic mail to the author.

=head1 AUTHOR

Tom Wyant (harryfmudd at comcast dot net)

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2016-2017, 2019-2022, 2026 by Thomas R. Wyant, III

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the files F<LICENSE-Artistic> and F<LICENSE-GPL>.

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.

=cut

# ex: set textwidth=72 :
