File Coverage

blib/lib/FBP/Parser.pm

Criterion	Covered	Total	%
statement	86	90	95.5
branch	11	18	61.1
condition	2	2	100.0
subroutine	21	21	100.0
pod	3	15	20.0
total	123	146	84.2

package FBP::Parser;

use 5.008005;
use strict;
use warnings;
use Params::Util   ();
use XML::SAX::Base ();
use FBP            ();

our $VERSION = '0.41';
our @ISA     = 'XML::SAX::Base';

# Object XML class to Perl class mapping
my %OBJECT_CLASS = (
	Project                => 'FBP::Project',
	Dialog                 => 'FBP::Dialog',
	Frame                  => 'FBP::Frame',
	Panel                  => 'FBP::FormPanel',

	# Direct Mappings
	wxAnimationCtrl        => 'FBP::AnimationCtrl',
	wxBitmapButton         => 'FBP::BitmapButton',
	wxBoxSizer             => 'FBP::BoxSizer',
	wxButton               => 'FBP::Button',
	wxCalendarCtrl         => 'FBP::CalendarCtrl',
	wxCheckBox             => 'FBP::CheckBox',
	wxChoice               => 'FBP::Choice',
	wxChoicebook           => 'FBP::Choicebook',
	wxComboBox             => 'FBP::ComboBox',
	wxColourPickerCtrl     => 'FBP::ColourPickerCtrl',
	wxDatePickerCtrl       => 'FBP::DatePickerCtrl',
	wxDirPickerCtrl        => 'FBP::DirPickerCtrl',
	wxFilePickerCtrl       => 'FBP::FilePickerCtrl',
	wxFlexGridSizer        => 'FBP::FlexGridSizer',
	wxFontPickerCtrl       => 'FBP::FontPickerCtrl',
	wxGauge                => 'FBP::Gauge',
	wxGenericDirCtrl       => 'FBP::GenericDirCtrl',
	wxGrid                 => 'FBP::Grid',
	wxGridBagSizer         => 'FBP::GridBagSizer',
	wxGridSizer            => 'FBP::GridSizer',
	wxHtmlWindow           => 'FBP::HtmlWindow',
	wxHyperlinkCtrl        => 'FBP::HyperlinkCtrl',
	wxListbook             => 'FBP::Listbook',
	wxListBox              => 'FBP::ListBox',
	wxListCtrl             => 'FBP::ListCtrl',
	wxMenu                 => 'FBP::Menu',
	wxMenuBar              => 'FBP::MenuBar',
	wxMenuItem             => 'FBP::MenuItem',
	wxNotebook             => 'FBP::Notebook',
	wxPanel                => 'FBP::Panel',
	wxRadioBox             => 'FBP::RadioBox',
	wxRadioButton          => 'FBP::RadioButton',
	wxRichTextCtrl         => 'FBP::RichTextCtrl',
	wxScrollBar            => 'FBP::ScrollBar',
	wxScrolledWindow       => 'FBP::ScrolledWindow',
	wxSearchCtrl           => 'FBP::SearchCtrl',
	wxSlider               => 'FBP::Slider',
	wxSpinButton           => 'FBP::SpinButton',
	wxSpinCtrl             => 'FBP::SpinCtrl',
	wxSplitterWindow       => 'FBP::SplitterWindow',
	wxStaticBitmap         => 'FBP::StaticBitmap',
	wxStaticBoxSizer       => 'FBP::StaticBoxSizer',
	wxStaticText           => 'FBP::StaticText',
	wxStaticLine           => 'FBP::StaticLine',
	wxStatusBar            => 'FBP::StatusBar',
	wxStdDialogButtonSizer => 'FBP::StdDialogButtonSizer',
	wxTextCtrl             => 'FBP::TextCtrl',
	wxToggleButton         => 'FBP::ToggleButton',
	wxToolBar              => 'FBP::ToolBar',
	wxTreeCtrl             => 'FBP::TreeCtrl',

	# Special Mappings
	choicebookpage         => 'FBP::ChoicebookPage',
	gbsizeritem            => 'FBP::GridBagSizerItem',
	listbookpage           => 'FBP::ListbookPage',
	notebookpage           => 'FBP::NotebookPage',
	sizeritem              => 'FBP::SizerItem',
	submenu                => 'FBP::Menu',
	separator              => 'FBP::MenuSeparator',
	spacer                 => 'FBP::Spacer',
	splitteritem           => 'FBP::SplitterItem',
	tool                   => 'FBP::Tool',
	toolSeparator          => 'FBP::ToolSeparator',
	CustomControl          => 'FBP::CustomControl',
);





######################################################################
# Constructor and Accessors

sub new {
	my $class  = Params::Util::_CLASS(shift);
	my $parent = Params::Util::_INSTANCE(shift, 'FBP');
	unless ( $parent ) {
		die("Did not provide a parent FBP object");
	}

	# Create the basic parsing object
	my $self = bless {
		raw   => 0,
		stack => [ $parent ],
	}, $class;

	$self;
}

sub parent {
	$_[0]->{stack}->[-1];
}





######################################################################
# Generic SAX Handlers

sub start_element {
	my $self    = shift;
	my $element = shift;

	# We don't support namespaces
	if ( $element->{Prefix} ) {
		die(__PACKAGE__ . ' does not support XML namespaces');
	}

	# Flatten the Attributes into a simple hash
	my %hash = map { $_->{LocalName}, $_->{Value} }
		grep { $_->{Value} =~ s/^\s+//; $_->{Value} =~ s/\s+$//; 1; }
		grep { ! $_->{Prefix} }
		values %{$element->{Attributes}};

	# Handle off to the appropriate tag-specific handler
	my $handler = 'start_element_' . lc $element->{LocalName};
	unless ( $self->can($handler) ) {
		die("No handler for tag $element->{LocalName}");
	}

	return $self->$handler( \%hash );
}

sub end_element {
	my ($self, $element) = @_;

	# Hand off to the optional tag-specific handler
	my $handler = 'end_element_' . lc $element->{LocalName};
	if ( $self->can($handler) ) {
		# If there is anything in the character buffer, trim whitespace
		if ( defined $self->{character_buffer} ) {
			$self->{character_buffer} =~ s/^\s+//;
			$self->{character_buffer} =~ s/\s+$//;
		}

		$self->$handler();
	}

	# Clean up
	delete $self->{character_buffer};

	1;
}

# Because we don't know in what context this will be called,
# we just store all character data in a character buffer
# and deal with it in the various end_element methods.
sub characters {
	# Add to the buffer
	$_[0]->{character_buffer} .= $_[1]->{Data};
}





######################################################################
# Tag-Specific SAX Handlers

#
# Top level contain, appears to serve no useful purpose.
# So lets just set the container context to be the root.
# This can just be ignored.
sub start_element_wxformbuilder_project {
	return 1;
}

sub end_element_wxformbuilder_project {
	return 1;
}

#
# Ignore the file version for now.
sub start_element_fileversion {
	return 1;
}

sub end_element_fileversion {
	return 1;
}

#
# Primary tag for useful elements in a GUI, such as windows and buttons.
sub start_element_object {
	my $self = shift;
	my $attr = shift;

	# Identify the type of object to create
	unless ( $OBJECT_CLASS{$attr->{class}} ) {
		die("Unknown or unsupported object class '$attr->{class}'");
	}

	# Store the raw hash until the closing tag
	$attr->{CLASS} = $OBJECT_CLASS{$attr->{class}};
	push @{$self->{stack}}, $attr;
}

sub end_element_object {
	my $self     = shift;
	my $attr     = pop @{$self->{stack}};
	my $class    = delete $attr->{CLASS};
	my $children = delete $attr->{children};
	my $object   = $class->new(
		%$attr,
		$self->{raw} ? ( raw      => $attr     ) : ( ),
		$children    ? ( children => $children ) : ( ),
	);
	$self->parent->{children} ||= [ ];
	push @{$self->parent->{children}}, $object;
}

#
# Primary tag for attributes of objects
sub start_element_property {
	my $self = shift;
	my $attr = shift;

	# Add a naked atribute hash to the stack
	$self->{character_buffer} = '';
	push @{$self->{stack}}, $attr->{name};
}

sub end_element_property {
	my $self  = shift;
	my $name  = pop @{$self->{stack}};
	my $value = $self->{character_buffer};
	$self->parent->{$name} = $value;
}

#
# Primary tag for events bound to objects
sub start_element_event {
	my $self = shift;
	my $attr = shift;

	# Add a naked atribute hash to the stack
	$self->{character_buffer} = '';
	push @{$self->{stack}}, $attr->{name};
}

sub end_element_event {
	my $self  = shift;
	my $name  = pop @{$self->{stack}};
	my $value = $self->{character_buffer};
	$self->parent->{$name} = $value if length $value;
}

1;