File Coverage

blib/lib/Devel/DebugInit/GDB.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Devel::DebugInit::GDB;
use Devel::DebugInit;
require Exporter;

@Devel::DebugInit::GDB::ISA = (Exporter, Devel::DebugInit);

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(

);
$VERSION = '0.1';

=head1 NAME

Devel::DebugInit::GDB - Perl extension for creating .gdbinit file from
C header file macros

=head1 SYNOPSIS

  use Devel::DebugInit::GDB;
  use Config;
  my $g = new Devel::DebugInit::GDB "filename => $Config{'archlib'}/CORE/perl.h";

  $g->write("~/perl5.00403/.gdbinit");

=head1 DESCRIPTION

This module is a backend for the GNU debugger, gdb, that is used
together with the generic Devel::DebugInit front end to produce an
initialization file for gdb. This module provides the output routines
that are specific for gdb. See L for more information.

=cut

# Preloaded methods go here.

=head1 METHODS

=head2 write()
=head2 write($filename)

This method outputs the macros to $filename, which defaults to
"./gdbinit".  It first writes out any macros without arguments (if
enabled, see L for more info), and
then it writes any macros with arguments.

=cut

sub write {
  my ($gdb,$outfile) = @_;
  my ($key,$defines,$file);
  $outfile = ".gdbinit" unless defined $outfile;

  open(INIT, ">$outfile") or die "Couldn't open $outfile for output";

  my $time = scalar gmtime;
  print INIT "# This file auto generated by GDBinit v$VERSION, ", $time, "\n";

  foreach $file (@{$gdb}) {

    # first print out the simple macros (ones without arguments)
    $defines = $file->get_no_args();
    if (defined $defines) {
      print INIT "# macros with no arguments\n\n";
      # sort keys to print them in alphabetical order
      foreach $key (sort keys %{$defines}) {
	my $macro = $defines->{$key};
	# The follow lines filter what to print

	# don't print bad macros
	next unless $gdb->scan($key,$macro);

	#don't print symbol renames, e.g. #define sv_grow Perl_sv_grow
	if ($macro =~ /^\s*\w+\s*$/) {
	  # it's just a single token, skip it if it's not a number
	  next unless $macro =~ /^\s*\d+\s*$/ || $macro =~ /^\s*0x\d+\s*$/;
	}

	# print the rest
	print INIT "define $key\n";
	print INIT "   print $macro\n";
	print INIT "end\n\n";
      }
    }

    # then print out the macros with arguments
    $defines = $file->get_args();
    if (defined $defines) {
      print INIT "\n\n# macros with arguments\n\n";
      # sort keys to print them in alphabetical order
      foreach $key (sort keys %{$defines}) {
	my $args  = $defines->{$key}->[0]; # first slot is the arg list
	my $macro = $defines->{$key}->[1]; # second slot is the macro

	# don't print bad macros
	next unless $gdb->scan($key,$macro);

	# substitue $arg0, $arg1, etc for the arguments to the macro
	my $print_arg = 0;
	foreach my $arg (@{$args}) {
	  $macro =~ s/\b$arg\b/\$arg$print_arg/g;
	  $print_arg++;
	}

	# print 'em out...
	print INIT "define $key\n";
	print INIT "   print $macro\n";
	print INIT "end\n\n";
      }
    }
  }
  close(INIT);
}

=head2 scan($name,$macro)

This is used by the print function to determine if $macro should be
printed or not. It returns 0 if the macro should NOT be
printed. Currently, the method rejects undefined macros (this is
possible if the user specified printing of local macros only), empty
macros (typical compiler flags like -DDEBUG, or #define linux), macros
whose names begin with '_', as well as any macro whose name is a
built-in GDB command.

This function can be overloaded by the user to more rigidly restrict
the output of print. For example:

    package myGDB;
    use Devel::DebugInit::GDB;
    @myGDB::ISA = (Devel::DebugInit::GDB);

    sub scan {
      my ($gdb,$key,$macro) = @_;

      #first give the superclass scan a chance
      return 0 unless $gdb->SUPER::scan(@_);

      # dont' print out any macros beginning with 'rfsf_'
      return 0 if $macro =~ /^rfsf_/;

      # print the rest
      return 1;
    }

=cut

sub scan {
  my ($gdb,$key,$macro) = @_;

  # if the user is printing only the local macros, it is possible for
  # some to be undefined.
  return 0 unless defined $macro;

  # don't print flags, e.g. #define VMS
  return 0 if $macro eq "";

  # get ready to do some regexp'ing on $key
  study $key;

  # don't print macros with names that begin with '_'
  return 0 if $key =~ /^_/;

  # don't redefine any builtin GDB commands
  return 0 if $key =~ /\b
    (kill|
     target|
     handle|
     run|
     jump|
     step|
     next|
     finish|
     nexti|
     stepi|
     continue|
     signal|
     detach|
     attach|
     unset|
     tty|
     thread|
     apply|
     bt|
     backtrace|
     select\-frame|
     frame|
     down|
     up|
     return|
     whatis|
     ptype|
     inspect|
     print|
     call|
     set|
     output|
     printf|
     display|
     undisplay|
     disassemble|
     x|
     delete|
     disable|
     enable|
     awatch|
     rwatch|
     watch|
     catch|
     break|
     clear|
     thbreak|
     hbreak|
     tbreak|
     condition|
     commands|
     ignore|
     cd|
     pwd|
     core\-file|
     section|
     exec\-file|
     file|
     sharedlibrary|
     path|
     load|
     symbol\-file|
     list|
     reversed\-search|
     search|
     forward\-search|
     directory|
     show|
     info|
     up\-silently|
     down\-silently|
     define|
     ni|
     si|
     where|
     complete|
     remote|
     maintenance)\b/ix;

  # Looks OK
  return 1;
}

1;

__END__