/ 
GTop-0.11
River stage one • 2 direct dependents • 2 total dependents
/ GTop

NAME

GTop - Perl interface to libgtop

SYNOPSIS

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

DESCRIPTION

Perl interface to libgtop:

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

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;

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', ); }

my %config = get_glibtop_config();

WriteMakefile( @insure, NAME => 'GTop', VERSION_FROM => 'GTop.pm', INC => join(" ", $GTOP_INCLUDE, $ginc, $config{incs}), LIBS => [join(" ", $GTOP_LIB, $config{libs})], 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 }

# get libgtop CFLAGS/LIBS across 1.x-2.x versions sub get_glibtop_config { my %c = ();

if (system('pkg-config --exists libgtop-2.0') == 0) {
    # 2.x
    chomp($c{incs} = qx|pkg-config --cflags libgtop-2.0|);
    chomp($c{libs} = qx|pkg-config --libs   libgtop-2.0|);

    # 2.0.0 bugfix
    chomp(my $libdir = qx|pkg-config --variable=libdir libgtop-2.0|);
    $c{libs} =~ s|\$\(libdir\)|$libdir|;
}
elsif (system('gnome-config --libs libgtop') == 0) {
    chomp($c{incs} = qx|gnome-config --cflags libgtop|);
    chomp($c{libs} = qx|gnome-config --libs   libgtop|);

    # buggy ( < 1.0.9?) versions fixup
    $c{incs} =~ s|^/|-I/|;
    $c{libs} =~ s|^/|-L/|;
}

return %c;
}