view release on metacpan or  search on metacpan

bin/gpsketcher  view on Meta::CPAN

use strict;
use warnings;
use Getopt::Std;

our $VERSION = '0.4';

my %opts;
getopts( 'hvg:o:', \%opts );

sub help {
    print<<EOH;
gpsketcher $VERSION, a Glade-Perl code sketcher for Gtk2::GladeXML::Simple

usage: gpsketcher -g glade_file [options]

[options]:

   -h               This message
   -o output_file   file to write the output code to
   -v               Prints the program version

Bug reports and suggestions to <marcoam\@perl.org.mx>
EOH
}

help() and exit if $opts{h};
print "gpsketcher $VERSION\n" and exit if $opts{v};

die "You need to specify a glade file with the -g option"
  unless defined $opts{g};
my $parser = Parser->new( $opts{g} );
my $parser_factory = XML::SAX::ParserFactory->parser( Handler => $parser );
$parser_factory->parse_uri( $opts{g} );
my $codegen = CodeGen->new( $parser->get_data );
$codegen->build( $opts{o} );
$codegen->write_file;

############################################################
#
# Class: Parser
#
# Description:
# Builds up a data tree from a glade XML file using SAX
# events.
#
############################################################

package Parser;

use XML::SAX;

use base qw( XML::SAX::Base );

use constant TRUE => 1;
use constant FALSE => !TRUE;

sub new {
    my ( $class, $glade_file ) = @_;
    die "Invalid glade file filename" unless $glade_file =~ /\.glade$/;
    my $self = bless { } => $class;
    $self->{creation_function} = FALSE; # is it creation_function?
    $self->{requires_gnome} = FALSE; # is it a Gnome App?
    $self->{data} = {}; # data tree for CodeGen
    $self->{stack} = []; # widgets stack
    $self->{main_widget} = FALSE; # is main_widget set?
    $self->{data}{glade_file} = $glade_file;
    $self->{data}{date} = localtime( time );
    $self->{data}{program_name} = ( split /\./, $glade_file )[0];
    return $self;
}

sub get_data { shift->{data} }

sub on_widget {
    my ( $self, $element ) = @_;
    my $widget = $element->{Attributes}{"{}id"}{Value};
    unless ( @{ $self->{stack} } ) {
	if ( !$self->{main_widget } ) {
	    $self->{data}{main_package} = { name => $widget };
	} else {
	    $self->{data}{packages}{$widget} = { name => $widget };
	}
	$self->{top_widget} = $widget;
    }
    push @{ $self->{stack} }, $widget;
}

sub on_signal {
    my ( $self, $element ) = @_;
    my $widget = $self->_peek;
    my $handler = $element->{Attributes}{"{}handler"}{Value};
    if ( $self->{main_widget} ) {
	my $node = $self->{data}{packages}{$self->{top_widget}};
	push @{ $node->{callbacks} }, {
				       widget_name => $widget,
				       name => $handler
				      };
    } else {
	my $node = $self->{data}{main_package};
	push @{ $node->{callbacks} }, {
				       widget_name => $widget,
				       name => $handler
				      };
    }
}

sub on_property {
    my ( $self, $element ) = @_;
    my $prop = $element->{Attributes}{"{}name"}{Value};
    $self->{creation_function} = TRUE if $prop eq 'creation_function';
}

sub on_widget_end {
    my ( $self, $element ) = @_;
    my $widget = pop @{ $self->{stack} };
    $self->{main_widget} = TRUE if $widget eq $self->{top_widget};
}

sub on_property_end { shift->{creation_function} = FALSE }