Possibly useful script for Glade users

["Matthew Braid" <ptkperl mdb id au>]

Hi all,

I've been using the following script (well, actually a much messier
version, but I cleaned it up :) to help me find callbacks that are
specified in a glade file. Depending on how its invoked it can give
you information on the event that triggers it and the widget class and
name that its attached to. It can also make a package skeleton if you
want it to, but that's more of a pretty way to display it rather than
something to actually use.

Just thought someone might find it useful :)

MB

#!/usr/bin/perl
use strict;
use XML::Simple;
{
 my $opts = scan_options();
 my $handlers = {};
 scan_level(XMLin($opts->{file}, ForceArray => 1), $handlers, $opts);
 output_code($handlers, $opts);
 exit;
}

sub scan_options {
 my %opts;
 while (scalar(@ARGV)) {
   my $opt = shift(@ARGV);
   if ($opt eq '--') {
     $opts{file} = shift(@ARGV);
     last;
   } elsif (index($opt, '-') != 0) {
     $opts{file} = $opt;
     last;
   } elsif ($opt eq '-t') {
     $opts{indent} = "\t" x shift(@ARGV);
   } elsif ($opt eq '-s') {
     $opts{indent} = " " x shift(@ARGV);
   } elsif ($opt eq '-w') {
     $opts{toplevel} = shift(@ARGV);
   } elsif ($opt eq '-p') {
     $opts{package} = shift(@ARGV);
   } elsif ($opt eq '-o') {
     $opts{oo} = 1;
   } elsif ($opt eq '-q') {
     $opts{quiet} = 1;
   } elsif ($opt eq '-v') {
     $opts{quiet} = 0;
   } elsif ($opt eq '-h') {
     print <<STOP;
scanglade.pl [OPTIONS] FILE
Find and display the callbacks specified in a Glade XML file.

OPTIONS
   -q     - Quiet. In package mode, don\'t add comments to the skeleton.
            In display mode, only show callback names, not widget and signal
            names.
   -v     - Verbose. In package mode, add comments to the skeleton.
            In display mode, include information on the widget name and type
            and the signal that triggers the callback.
   -p PKG - Switch to package mode. This will create a package skeleton, with
            a package name of PKG. Note it is not advisable to use this
            skeleton as is - auto-generated code is rarely what you need.
   -o     - Only available in package mode, create an 'Object Oriented'
            package - ie, include a new() function and add my \$self = shift;
            to all methods.
   -w WID - Similar to Gtk2::GladeXML\'s 2nd argument to new(), WID is the
            name of the widget to start parsing from. Only it and any children
            will be scanned for callbacks.
   -s NUM - In 'Object Oriented' package mode, set the indent to be NUM
            spaces.
   -t NUM - In 'Object Oriented' package mode, set the indent to be NUM tabs.
            The default is 1 tab, equivalent to -t 1.

STOP
     exit;
   } else {
     die "Unknown option '$opt'";
   }
 }
 $opts{indent} = "\t" if not defined $opts{indent};
 if (scalar(@ARGV)) {
   die "Extra arguments after filename!";
 } elsif (not defined $opts{file}) {
   die "No filename supplied!";
 }
 if ($opts{oo} and not defined $opts{package}) {
   die "Package name must be supplied for OO option";
 }
 return \%opts;
}

sub scan_level {
 my ($lev, $handlers, $opts, $widgets, $active) = @_;
 $widgets = [] if not defined $widgets;
 $active = 1 if not defined $opts->{toplevel};
 for my $k (keys %$lev) {
   if ($k eq 'widget') {
     for my $sk (keys %{$lev->{$k}}) {
       my $toggle = 1 if not $active and $sk eq $opts->{toplevel};
       $active = 1 if $toggle;
       unshift @$widgets, [$lev->{$k}{$sk}{class} =~ /^Gtk(.*)\z/, $sk];
       scan_level($lev->{$k}{$sk}, $handlers, $opts, $widgets, $active);
       shift @$widgets;
       $active = 0 if $toggle;
     }
   } elsif ($k eq 'signal') {
     next if not $active;
     for my $sk (keys %{$lev->{$k}}) {
       my $hname = $lev->{$k}{$sk}{handler};
       push @{$handlers->{$hname}}, [$sk, @{$widgets->[0]}];
     }
   } elsif (ref($lev->{$k}) eq 'HASH') {
     scan_level($lev->{$k}, $handlers, $opts, $widgets, $active);
   } elsif (ref($lev->{$k}) eq 'ARRAY') {
     for my $val (@{$lev->{$k}}) {
       scan_level($val, $handlers, $opts, $widgets, $active);
     }
   }
 }
}

sub output_code {
 my ($handlers, $opts) = @_;
 if (defined($opts->{package})) {
   print "package $opts->{package};\n\nuse strict;\n\n";
 }
 if ($opts->{oo}) {
   print <<STOP;
sub new {
$opts->{indent}my \$class = shift;
$opts->{indent}return bless({}, (ref(\$class) or \$class or __PACKAGE__));
}

STOP
 }
 for my $handler (keys %$handlers) {
   if (defined($opts->{package})) {
     if (not $opts->{quiet}) {
       for my $desc (@{$handlers->{$handler}}) {
         printf("# Handler for event '%s' on %s widget '%s'\n",
                $desc->[0], $desc->[1], $desc->[2]);
       }
     }
     if ($opts->{oo}) {
       print "sub $handler {\n$opts->{indent}my \$self = shift;\n}\n\n";
     } else {
       print "sub $handler { }\n\n";
     }
   } else {
     if ($opts->{quiet}) {
       print "$handler\n";
     } else {
       for my $desc (@{$handlers->{$handler}}) {
         printf("%s %s %s %s\n",
                $desc->[1], $desc->[2], $desc->[0], $handler);
       }
     }
   }
 }
 print "1;\n__END__\n" if defined $opts->{package};
}

__END__