diff --git a/perl/ChangeLog b/perl/ChangeLog new file mode 100644 index 00000000..1dd10238 --- /dev/null +++ b/perl/ChangeLog @@ -0,0 +1,10 @@ +1998-10-10 Martin Baulig + + * typemap: New file. + + * perl.awk: Make it work with the new format of `features.def'. + + * Makefile.PL.in: Added typemap. + + * Libgtop.pm (new): New function. + diff --git a/perl/Libgtop.pm b/perl/Libgtop.pm index e146b93c..3618a457 100644 --- a/perl/Libgtop.pm +++ b/perl/Libgtop.pm @@ -20,6 +20,13 @@ bootstrap Libgtop $VERSION; # Preloaded methods go here. +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = Libgtop::init ($class); + return $self; +} + # Autoload methods go after __END__, and are processed by the autosplit program. 1; diff --git a/perl/Makefile.PL.in b/perl/Makefile.PL.in index 1365c98d..a9e2a1c1 100644 --- a/perl/Makefile.PL.in +++ b/perl/Makefile.PL.in @@ -3,7 +3,8 @@ use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile('NAME' => 'Libgtop', - 'VERSION_FROM' => 'Libgtop.pm', + 'VERSION_FROM' => '@srcdir@/Libgtop.pm', + 'TYPEMAPS' => ['@srcdir@/typemap' ], 'LIBS' => ['@LIBGTOP_GUILE_LIBS@'], 'DEFINE' => '', 'INC' => '@LIBGTOP_GUILE_INCS@', diff --git a/perl/new.pl b/perl/new.pl index b6e0faca..5dabd099 100755 --- a/perl/new.pl +++ b/perl/new.pl @@ -6,8 +6,11 @@ use blib; use strict; use Libgtop; -print "CPU Usage: ".join (':', Libgtop::cpu)."\n"; -print "Memory Usage: ".join (':', Libgtop::mem)."\n"; -print "Swap Usage: ".join (':', Libgtop::swap)."\n"; +my $server = Libgtop->new; +print "CPU Usage: ".join (':', $server->cpu)."\n"; +print "Memory Usage: ".join (':', $server->mem)."\n"; +print "Swap Usage: ".join (':', $server->swap)."\n"; + +print "Process List: ".join (' ', $server->proclist (0,0))."\n"; diff --git a/perl/perl.awk b/perl/perl.awk index 1b3bc513..47198f1c 100644 --- a/perl/perl.awk +++ b/perl/perl.awk @@ -17,33 +17,81 @@ BEGIN { print ""; print "#include "; print "#include "; + print "#include "; print ""; print "MODULE = Libgtop\t\tPACKAGE = Libgtop"; print ""; + print "PROTOTYPES: ENABLE"; + print ""; + print "glibtop *"; + print "init (CLASS)"; + print "\tchar *CLASS;"; + print "CODE:"; + print "\tRETVAL = glibtop_calloc (1, sizeof (glibtop *));"; + print "\tglibtop_init_s (&RETVAL, 0, 0);"; + print "OUTPUT:"; + print "\tRETVAL"; + print ""; + + type_convert["long"] = "int64_t"; + type_convert["ulong"] = "u_int64_t"; + type_convert["pid_t"] = "pid_t"; + type_convert["int"] = "int"; convert["long"] = "newSViv"; convert["ulong"] = "newSViv"; convert["double"] = "newSVnv"; } -/^(\w+)/ { - feature = $1; +function output(line) { + split (line, line_fields, /\|/); + retval = line_fields[1]; + feature = line_fields[2]; + element_def = line_fields[3]; + param_def = line_fields[4]; - print "void"; - if (feature ~ /^proc_/) { - print feature"(pid)"; - print "\tunsigned\tpid;"; + orig = feature; sub(/^@/,"",feature); + space = feature; gsub(/./," ",space); + + if (feature ~ /^proc_map/) + return; + else if (feature ~ /^mountlist/) + return; + else if (feature ~ /^fsusage/) + return; + + if (param_def == "string") { + call_param = line_fields[5]; + param_decl = "\tconst char *"line_fields[5]";\n"; } else { - print feature"()"; + call_param = ""; + param_decl = ""; + nr_params = split (param_def, params, /:/); + for (param = 1; param <= nr_params; param++) { + list = params[param]; + type = params[param]; + sub(/\(.*/, "", type); + sub(/^.*\(/, "", list); sub(/\)$/, "", list); + count = split (list, fields, /,/); + for (field = 1; field <= count; field++) { + param_decl = param_decl"\t"; + call_param = call_param", "; + param_decl = param_decl""type_convert[type]" "fields[field]";\n"; + call_param = call_param""fields[field]; + } + } } - - print "PREINIT:"; + + print "void"; + print feature" (server"call_param")"; + print "\tglibtop *server;"; + print param_decl"PREINIT:"; print "\tglibtop_"feature" "feature";"; if (feature ~ /^proclist/) { print "\tunsigned i, *ptr;"; print "PPCODE:"; - print "\tptr = glibtop_get_proclist (&proclist);"; + print "\tptr = glibtop_get_proclist (&proclist, which, arg);"; print ""; print "\tif (ptr) {"; print "\t\tfor (i = 0; i < proclist.number; i++)"; @@ -53,28 +101,27 @@ BEGIN { print "\tglibtop_free (ptr);"; } else { print "PPCODE:"; - if (feature ~ /^proc_/) { - print "\tglibtop_get_"feature" (&"feature", pid);"; - } else { - print "\tglibtop_get_"feature" (&"feature");"; - } + if (call_param != "") + print "\tglibtop_get_"feature"_l (server, &"feature""call_param");"; + else + print "\tglibtop_get_"feature"_l (server, &"feature");"; print ""; - nr_elements = split ($2, elements, /:/); + nr_elements = split (element_def, elements, /:/); for (element = 1; element <= nr_elements; element++) { list = elements[element]; type = elements[element]; sub(/\(.*/, "", type); - sub(/^\w+\(/, "", list); sub(/\)$/, "", list); + sub(/^.*\(/, "", list); sub(/\)$/, "", list); count = split (list, fields, /,/); for (field = 1; field <= count; field++) { if (type ~ /^str$/) { - print "\tXPUSHs (sv_2mortal (newSVpv ("$1"."fields[field]", 0)));"; + print "\tXPUSHs (sv_2mortal (newSVpv ("feature"."fields[field]", 0)));"; } else { if (type ~ /^char$/) { - print "\tXPUSHs (sv_2mortal (newSVpv (&"$1"."fields[field]", 1)));"; + print "\tXPUSHs (sv_2mortal (newSVpv (&"feature"."fields[field]", 1)));"; } else { - print "\tXPUSHs (sv_2mortal ("convert[type]" ("$1"."fields[field]")));"; + print "\tXPUSHs (sv_2mortal ("convert[type]" ("feature"."fields[field]")));"; } } } @@ -84,3 +131,5 @@ BEGIN { print ""; } +/^[^#]/ { output($0) } + diff --git a/perl/typemap b/perl/typemap new file mode 100644 index 00000000..4d2d2cc2 --- /dev/null +++ b/perl/typemap @@ -0,0 +1,22 @@ +TYPEMAP +int64_t T_IV +pid_t T_IV +const char * T_PV + +glibtop * O_OBJECT + +OUTPUT +# The Perl object is blessed into 'CLASS', which should be a +# char* having the name of the package for the blessing. +O_OBJECT + sv_setref_pv ($arg, CLASS, (void*)$var); + +INPUT +O_OBJECT + if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG)) + $var = ($type)SvIV((SV*)SvRV($arg)); + else { + warn (\"${Package}::$func_name() -- \" + \"$var is not a blessed SV reference\"); + XSRETURN_UNDEF; + }