The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use 5.005;
use ExtUtils::MakeMaker;

use strict;

my %interface = (
    'cpu' => [qw(flags total user nice sys idle frequency)],
    'mem' => [qw(flags total used free shared buffer cached user locked)],
    'proc_mem'  => [qw(flags size vsize resident share rss rss_rlim)],
    'proc_time' => [qw(flags start_time rtime utime stime cutime cstime
		       timeout it_real_value frequency)],
    'proc_map' => [qw(flags number total size)],
    'proc_args' => [qw(flags size)],
    'proc_uid' => [qw(flags uid:int euid:int gid:int egid:int pid:int 
		      ppid:int pgrp:int session:int tty:int
		      tpgid:int priority:int nice:int)],
    'map_entry' => [],
    'swap' => [qw(flags total used free pagein pageout)],
    'proc_segment' => [qw(flags text_rss shlib_rss data_rss stack_rss 
			  dirty_size start_code end_code start_stack)],
    'proc_state' => [qw(flags)],
    'netload' => [qw(flags if_flags mtu subnet address packets_in 
		     packets_out packets_total bytes_in bytes_out 
		     bytes_total errors_in errors_out errors_total
		     collisions)],
    'mountlist' => [qw(flags number total size)],
    'proclist' => [qw(flags number total size)],
    'mountentry' => [],
    'fsusage' => [qw(flags blocks bfree bavail files ffree)],
    'uptime' => [qw(flags)],
    'loadavg' => [qw(flags nr_running nr_tasks last_pid)],
);

open TYPEMAP, ">typemap.gtop" or die $!;
open BOOTINC, ">gtop.boot" or die $!;
open BOOTXS, ">gtopxs.boot" or die $!;
open XS, ">xs.gtop" or die $!;
open POD, ">GTop.pod" or die $!;
open TEST, ">test.gtop" or die $!;

print BOOTXS "static void boot_GTop_interface(void)\n{\n";

print TEST <<'EOF';
use strict;
use ExtUtils::testlib;
use GTop ();

my $gtop = GTop->new;

EOF

print POD <<EOF;
=head1 NAME

GTop - Perl interface to libgtop

=head1 SYNOPSIS

 use GTop ();
 my \$gtop = GTop->new;

=head1 DESCRIPTION

Perl interface to libgtop:

 http://home-of-linux.org/gnome/libgtop/

=head1 CLASSES

EOF

my %constructors = map {$_,1} qw(mountlist proclist proc_map mountentry 
				 proc_args map_entry);
my %notunion = map {$_,1} qw(mountentry map_entry);
use constant IS_SOLARIS => $^O eq 'solaris';

for my $if (sort keys %interface) {
    local *FH;
    (my $leaf = $if) =~ s/_(.)/uc $1/e;
    my $class = sprintf "GTop::%s", ucfirst $leaf;
    (my $typedef = $class) =~ s/:/_/g;

    print BOOTXS "    boot_GTop_$if();\n";

    print TYPEMAP "$class\tT_PTROBJ\n";

    print BOOTINC "typedef glibtop_$if * $typedef;\n";
    print BOOTINC qq(\#include "$if.boot"\n);

    my(@args) = ('','','','()');

    if ($if =~ /^proc_/)  { 
	@args = (', pid', 'pid_t pid', '($pid)', '($$)');
    }
    elsif ($if =~ /^netload/) {
	@args = (', interface', 'char * interface', 
		'($interface)', '(\'eth0\')');
    }
    elsif ($if =~ /^mountlist/) {
	@args = (', all_fs', 'int all_fs', '($all_fs)', '(1)');
    }
    elsif ($if =~ /^fsusage/) {
	@args = (', disk', 'char *disk', '($disk)', '(\'/\')');
    }

    print XS <<EOF unless $constructors{$if};

$class
$if(gtop$args[0])
    GTop gtop
    $args[1]

    CODE:
    RETVAL = (glibtop_$if *)safemalloc(sizeof(*RETVAL));
    trace_malloc(RETVAL);
    Zero(RETVAL, 1, glibtop_$if);
    glibtop_get_$if(RETVAL$args[0]);

    OUTPUT:
    RETVAL

EOF

    print TEST <<EOF unless $notunion{$if};

my \$$if = \$gtop->$if$args[3];
print "$if\\n";
for (qw(@{ $interface{$if} })) {
    s/:\\w+\$//;
    printf "   %s => %d\\n", \$_, \$$if->\$_();
}

EOF

    unless ($notunion{$if}) {
	print POD "\n=head2 $class\n";
	print POD "\n    my \$$if = \$gtop->$if$args[2];\n\n";
	print POD "=over 4\n";
    }

    open FH, ">$if.boot" or die $!;

    if (IS_SOLARIS) {
	for my $entry (@{ $interface{$if} }) {
	    my $type = 'u_int64_t'; 
	    if ($entry =~ s/:(\w+)$//) {
		$type = $1;
	    }
	    my $field = $entry;
	    my $xsname = "XS_glibtop_${if}_$field";
	    print FH <<EOF;
static XS($xsname)
{
    dXSARGS; 

    glibtop_$if *s = (void *)SvIV((SV*)SvRV(ST(0)));

    ST(0) = sv_2mortal(newSVnv((unsigned long)s->$field));

    XSRETURN(1); 
}
EOF
          }
}

    print FH "static void boot_GTop_$if (void)\n{\n";

    for my $entry (@{ $interface{$if} }) {
	my $type = 'u_int64_t'; 
	if ($entry =~ s/:(\w+)$//) {
	    $type = $1;
	}
	my $field = $entry;
	my $method = join '::', $class, $field;
	my $xsname = "XS_glibtop_${if}_$field";
	if (IS_SOLARIS) {
	    print FH qq{   newXS("$method", $xsname, __FILE__);\n};
	}
	else {
	    print FH qq{   newGTopXS_$type("$method", glibtop_$if, $field);\n};
	}

	unless ($notunion{$if}) {
	    print POD "\n=item $field\n\n";
	    print POD "    my \$$field = \$$if->$field;\n";
	}
    }
    print FH qq{   newXS("$class\::DESTROY", XS_GTop_destroy, __FILE__);\n} 
    unless $notunion{$if};

    print FH "\n}\n";

    print POD "\n=back\n" unless $notunion{$if};
}

print BOOTXS "\n}\n";
print POD <<EOF;

=head1 AUTHOR

Doug MacEachern

EOF

close TYPEMAP;
close BOOTINC;
close BOOTXS;
close XS;
close POD;
close TEST;

my $GTOP_LIB = "";
if (my $path = $ENV{GTOP_LIB}) {
    $GTOP_LIB = "-L$path ";
}
my $GTOP_INCLUDE = "";
if (my $path = $ENV{GTOP_INCLUDE}) {
    $GTOP_INCLUDE = "-I$path ";
}

chomp(my $ginc = `glib-config --cflags`);
#needed for remote connection
my $xlibs = "-L/usr/X11/lib -L/usr/X11R6/lib -lXau";

my @insure = ();
if (0) {
    @insure = (
       OPTIMIZE => '-g',
       CC => 'insure gcc',
       LD => 'insure gcc',
    );
}

WriteMakefile(
   @insure,
   NAME => 'GTop',
   VERSION_FROM => 'GTop.pm',
   INC => $GTOP_INCLUDE . $ginc,
   LIBS => [$GTOP_LIB . "-lgtop -lgtop_sysdeps -lgtop_common -lglib $xlibs"],
   TYPEMAPS => [qw(typemap.gtop typemap)],
   clean   => {
       FILES => "@{[<*.boot>, <*.gtop>]}",
   },
   'macro' => {
	  CVSROOT => 'modperl.com:/local/cvs_repository',
   },
);

sub MY::postamble { 
    return <<'EOF'; 

cvs_tag :
	cvs -d $(CVSROOT) tag v$(VERSION_SYM) . 
	@echo update GTop.pm VERSION now 
EOF
}