#!/usr/bin/perl

use strict;
use Getopt::Long;

use POSIX qw(dup2);
use Devel::Peek;

use constant MEGAIOC_QNADAP     => 'm';   # Query # of adapters
use constant MEGAIOC_QDRVRVER   => 'e';   # Query driver version
use constant MEGAIOC_QADAPINFO  => 'g';   # Query driver version

use constant MEGA_IOCTL => 0xc06e6d00;    # rw + length 110 + 'm' + subcode 0

open (D, "/dev/megadev") 
    or open (D, "/dev/megadev0") 
    or die "No /dev/megadev or /dev/megadev0 device node found.\n";

# this Perl scalar (SV) will be our ioctl read/write struct that we
# pass to/read from the kernel.

my $struct = "\0" x 110;

# where we'll ask the kernel to write data back to us.  (max 4k
# according to something in the kernel source)

my $userbuf = " " x 4096;
my $userbuf_ptr = get_c_pointer(\$userbuf);

my $nadap = num_adapters();
if (defined $nadap) {
    print "Number of adapters: $nadap\n";   
} else {
    print "No adapters found.\n";
    exit 0;
}

for my $i (0..$nadap-1) {
    print "Adapter \#$i:\n";
    adap_info(0);
    hexdump(\$userbuf);
}

sub wipe_struct {
    substr($struct, 0, 110) = "\0" x 110;
}

sub num_adapters {
    wipe_struct();

    # opcode = 0x82, a driver command (not a mailbox command)
    substr($struct, 8, 1) = "\x82";

    # subopcode
    substr($struct, 9, 1) = MEGAIOC_QNADAP; 

    # set the data field, with the userspace pointer value to write the results back
    substr($struct, 110-8, 4) = $userbuf_ptr;
    
    my $rv = ioctl(D, MEGA_IOCTL, "$struct");  # needs to be in quotes, for reasons only partially understood
    if (! defined $rv || $rv < 0) {
	return undef;
    } else {
	return $rv;
    }
}

sub adap_info {
    my $anum = shift;

    wipe_struct();

    # opcode = 0x82, a driver command (not a mailbox command)
    substr($struct, 8, 1) = "\x82";

    # subopcode
    substr($struct, 9, 1) = MEGAIOC_QADAPINFO; 

    # adapter info
    substr($struct, 10, 2) = chr($anum) . 'm';

    # set the data field, with the userspace pointer value to write the results back
    substr($struct, 110-8, 4) = $userbuf_ptr;

    hexdump(\$struct);
    
    my $rv = ioctl(D, MEGA_IOCTL, "$struct");  # needs to be in quotes, for reasons only partially understood
    print "rv: $rv (\$! = $!)\n";
    
}

sub hexdump {
    my $ref = shift;
    print "hex: ", join(' ', map { sprintf("%02x", ord($_)) } split //, $$ref), "\n";
    print "asc: ", join(' ', map { $_ =~ /[\w ]/ ? " $_" : " ." } split //, $$ref), "\n";
}

sub get_c_pointer {
    my $ref = shift;
    
    # now we have to find Perl's char* memory address holding the C string
    # in $$ref above.  the only default thing in Perl that can do this
    # is Devel::Peek, which can only write it to stderr.  And at an XS
    # layer, not a PerlIO layer, so we can't even tie the filehandle to a 
    # Perl class.  The only way to capture Devel::Peek's output is to dup 2
    # the stderr fd to another file, then parse that file.

    my $save = substr($$ref, 0, 6);
    my $filename = ".find-c-ptr.tmp";

    open (PEEK, ">$filename") or die "couldn't open temp file in current directory";
    dup2(fileno(PEEK), 2);
    substr($$ref, 0, 6) = "findme";  # something we can search for later
    Dump($userbuf);
    close PEEK;

    my $pv_hex;
    open (PEEK, $filename) or die "couldn't open just-created temp file";
    while (<PEEK>) {
	$pv_hex = $1 if /0x([\da-f]+).+findme/;
    }
    close PEEK;
    substr($userbuf, 0, 6) = $save;

    unlink $filename;

    die "Couldn't get SV's PV value for data pointer." unless $pv_hex;
    
    # Our (32-bit only for now) userspace address we want our results written back to
    # Note that "L" is always 4 bytes, host order, and you need "L!" to get the native
    # machine's long length
    return pack("L", hex($pv_hex));
}


