File Coverage

lib/Wx/WidgetMaker.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Wx::WidgetMaker;

require 5.006;

our $VERSION = '0.11';


use strict;
use warnings;
use Carp qw(carp confess);

use Wx qw(:everything);

use fields qw(_parent);

# Some constants for consistency's sake
use constant wxDefaultID     => -1;
use constant wxDefaultWidth  => -1;
use constant wxDefaultHeight => -1;
use constant wxDefaultX      => -1;
use constant wxDefaultY      => -1;
use constant wxDefaultStyle  => 0;
# Pointsize corresponding to h1, h2, etc.
use constant POINTSIZE => {
    1 => 20, 2 => 16, 3 => 12, 4 => 10, 5 => 9, 6 => 8,
};
# Prefix added to some widget names so that params can avoid them
use constant MAGICPREFIX => '!!!#!!##!###';


sub new {
    my $class = shift;
    my ($parent) = _rearrange([qw(PARENT)], @_);

    _require_param_type(\$parent, 'Wx::Window', '-parent');

    my $self = bless {}, $class;
    $self->{'_parent'} = $parent;

    return $self;
}


sub h1 {
    my ($self, $text) = @_;
    return $self->_h($text, 1);
}
sub h2 {
    my ($self, $text) = @_;
    return $self->_h($text, 2);
}
sub h3 {
    my ($self, $text) = @_;
    return $self->_h($text, 3);
}
sub h4 {
    my ($self, $text) = @_;
    return $self->_h($text, 4);
}
sub h5 {
    my ($self, $text) = @_;
    return $self->_h($text, 5);
}
sub h6 {
    my ($self, $text) = @_;
    return $self->_h($text, 6);
}


sub textfield {
    my $self = shift;
    my ($name, $default, $width, $maxlength, $id) =
        _rearrange(['NAME', [qw(DEFAULT VALUE)], 'SIZE', 'MAXLENGTH', 'ID'], @_);
    my ($textfield, $size);

    _require_param(\$name, '-name');
    _init_param(\$default, '');
    _init_param(\$id, wxDefaultID);

    if (defined $width) {
        if ($width =~ /^\d+$/) {
            $size = wxSIZE($width, wxDefaultHeight);
        } else {
            carp '-size argument ignored (not a whole number)';
        }
    }
    _init_param(\$size, wxDefaultSize);

    # XXX: maxlength not implemented yet, need to set a validator

    $textfield = Wx::TextCtrl->new(
        $self->{'_parent'}, $id, $default,
        wxDefaultPosition, $size,
        wxNO_BORDER, wxDefaultValidator, $name
    );

    return $textfield;
}


sub password_field {
    my $self = shift;
    my ($name, $default, $width, $maxlength, $id) =
        _rearrange(['NAME', [qw(DEFAULT VALUE)], 'SIZE', 'MAXLENGTH', 'ID'], @_);
    my ($password_field, $size);

    _require_param(\$name, '-name');
    _init_param(\$default, '');
    _init_param(\$id, wxDefaultID);

    if (defined $width) {
        if ($width =~ /^\d+$/) {
            $size = wxSIZE($width, wxDefaultHeight);
        } else {
            carp '-size argument ignored (not a whole number)';
        }
    }
    _init_param(\$size, wxDefaultSize);

    # XXX: maxlength not implemented yet, need to set a validator

    $password_field = Wx::TextCtrl->new(
        $self->{'_parent'}, $id, $default,
        wxDefaultPosition, $size,
        wxTE_PASSWORD, wxDefaultValidator, $name
    );

    return $password_field;
}


sub textarea {
    my $self = shift;
    my ($name, $default, $rows, $columns, $id) =
        _rearrange(['NAME',[qw(DEFAULT VALUE)],'ROWS',[qw(COLS COLUMNS)], 'ID'], @_);
    my ($textarea, $size);

    _require_param(\$name, '-name');
    _init_param(\$default, '');
    _init_param(\$id, wxDefaultID);

    if (defined $rows && defined $columns) {
        unless ($rows =~ /^\d+$/) {
            carp '-rows argument ignored (not a whole number)';
        }
        unless ($columns =~ /^\d+$/) {
            carp '-columns argument ignored (not a whole number)';
        }
        if ($rows =~ /^\d+$/ && $columns =~ /^\d+$/) {
            $size = wxSIZE($columns, $rows);
        }
    }
    _init_param(\$size, wxSIZE(100, 50));

    $textarea = Wx::TextCtrl->new(
        $self->{'_parent'}, $id, $default,
        wxDefaultPosition, $size,
        wxTE_MULTILINE, wxDefaultValidator, $name
    );

    return $textarea;
}


sub popup_menu {
    my $self = shift;
    my ($name, $values, $default, $labels, $id) =
        _rearrange(
            ['NAME', [qw(VALUES VALUE)], [qw(DEFAULT DEFAULTS)], 'LABELS', 'ID'],
            @_
        );
    my ($popup_menu);

    _require_param(\$name, '-name');
    _require_param_type(\$values, 'ARRAY', '-values');
    _init_param(\$default, $values->[0]);
    _init_param(\$id, wxDefaultID);

    $popup_menu = Wx::Choice->new(
        $self->{'_parent'}, $id, wxDefaultPosition, wxDefaultSize,
        _make_labels($values, $labels),
        wxDefaultStyle, wxDefaultValidator, $name
    );
    for (my $i = 0; $i < @$values; $i++) {
        $popup_menu->SetClientData($i, $values->[$i]);
    }
    $popup_menu->SetStringSelection($default);

    return $popup_menu;
}


sub scrolling_list {
    my $self = shift;
    my ($name, $values, $default, $height, $multiple, $labels, $id) =
        _rearrange(
            ['NAME', [qw(VALUE VALUES)], [qw(DEFAULT DEFAULTS)],
             'SIZE', 'MULTIPLE', 'LABELS', 'ID'],
            @_
        );
    my ($scrolling_list, @labels, $style, $size);

    _require_param(\$name, '-name');
    _require_param_type(\$values, 'ARRAY', '-values');
    _init_param(\$default, $values->[0]);
    _init_param(\$id, wxDefaultID);

    if (defined $height) {
        if ($height =~ /^\d+$/) {
            $size = wxSIZE(wxDefaultWidth, $height);
        } else {
            carp '-size argument ignored (not a whole number)';
        }
    }
    _init_param(\$size, wxSIZE(wxDefaultWidth, 50));

    if (defined $multiple && $multiple) {
        $style = wxLB_EXTENDED|wxLB_MULTIPLE;
    } else {
        $style = wxDefaultStyle;
    }

    $scrolling_list = Wx::ListBox->new(
        $self->{'_parent'}, $id, wxDefaultPosition, $size,
        _make_labels($values, $labels),
        wxCB_READONLY|$style, wxDefaultValidator, $name
    );

    for (my $i = 0; $i < @$values; $i++) {
        $scrolling_list->SetClientData($i, $values->[$i]);
    }
    $scrolling_list->SetStringSelection($default);

    return $scrolling_list;
}


sub checkbox_group {
    my $self = shift;
    my ($name, $values, $defaults, $linebreak, $labels, $rows, $columns,
        $rowheaders, $colheaders, $nolabels) =
            _rearrange(
                ['NAME', [qw(VALUE VALUES)], [qw(DEFAULT DEFAULTS)],
                 'LINEBREAK', 'LABELS', 'ROWS', [qw(COLUMNS COLS)],
                 'ROWHEADERS', 'COLHEADERS', 'NOLABELS'],
                @_
            );

    confess 'method not yet implemented';
}


sub checkbox {
    my $self = shift;
    my ($name, $checked, $value, $label, $id) =
        _rearrange(['NAME', [qw(CHECKED SELECTED ON)], 'VALUE', 'LABEL', 'ID'], @_);
    my ($checkbox);

    _require_param(\$name, '-name');
    _init_param(\$checked, 0);
    _init_param(\$label, $name);
    _init_param(\$id, wxDefaultID);

    $checkbox = Wx::CheckBox->new(
        $self->{'_parent'}, $id, $label,
        wxDefaultPosition, wxDefaultSize,
        wxDefaultStyle, wxDefaultValidator, $name
    );

    return $checkbox;
}


sub radio_group {
    my $self = shift;
    my ($name, $values, $default, $linebreak, $labels,
        $rows, $columns, $rowheaders, $colheaders, $nolabels,
        $caption, $id) =
            _rearrange(
                ['NAME', [qw(VALUES VALUE)], 'DEFAULT', 'LINEBREAK',
                 'LABELS', 'ROWS', [qw(COLUMNS COLS)],
                 'ROWHEADERS', 'COLHEADERS', 'NOLABELS', 'CAPTION', 'ID'],
                @_
            );
    my ($radio_group, $style, @labels, $major_dimension);

    _require_param(\$name, '-name');
    _require_param_type(\$values, 'ARRAY', '-values');
    _init_param(\$default, $values->[0]);
    _init_param(\$id, wxDefaultID);

    if (defined $nolabels && $nolabels) {
        @labels = map {''} @labels;
    } else {
        @labels = @{ _make_labels($values, $labels) };
    }

    _init_param(\$caption, '');

    _init_param(\$rows, 1);
    _init_param(\$columns, 1);
    if (defined $linebreak && $linebreak) {
        $style = wxRA_SPECIFY_COLS;
        $major_dimension = $columns;
    } else {
        $style = wxRA_SPECIFY_ROWS;
        $major_dimension = $rows;
    }

    $radio_group = Wx::RadioBox->new(
        $self->{'_parent'}, $id, $caption,
        wxDefaultPosition, wxDefaultSize,
        \@labels, $major_dimension,
        $style, wxDefaultValidator, $name
    );

    return $radio_group;
}


sub submit {
    my $self = shift;
    my ($name, $value, $id) = _rearrange(['NAME', [qw(VALUE LABEL)], 'ID'], @_);
    my ($button);

    _require_param(\$name, '-name');
    _init_param(\$value, 'Submit');
    _init_param(\$id, wxDefaultID);

    $button = Wx::Button->new(
        $self->{'_parent'}, $id, $value,
        wxDefaultPosition, wxDefaultSize, wxDefaultStyle,
        wxDefaultValidator, $name
    );

    return $button;
}


sub image_button {
    my $self = shift;
    my ($name, $src, $id) = _rearrange([qw(NAME SRC ID)], @_);
    my ($button, $bitmap);

    _require_param(\$name, '-name');
    _require_param(\$src, '-src');
    _init_param(\$id, wxDefaultID);

    $bitmap = _bitmap($src);
    $button = Wx::BitmapButton->new(
        $self->{'_parent'}, $id, $bitmap,
        wxDefaultPosition, wxDefaultSize, wxDefaultStyle,
        wxDefaultValidator, $name
    );

    return $button;
}


sub print {
    my $self = shift;
    my ($add, $sizer, $option, $flag, $border) =
        _rearrange([qw(ADD SIZER OPTION FLAG BORDER)], @_);

    _init_param(\$add, '');
    _init_param(\$option, 0);
    _init_param(\$flag, 0);
    _init_param(\$border, 0);

    if (defined $sizer) {
        _require_param_type(\$sizer, 'Wx::Sizer', '-sizer');

        if (ref($add) eq 'ARRAY') {
            foreach my $control (@$add) {
                _require_param_type(\$control, ['Wx::Control', 'Wx::Sizer']);
                $sizer->Add($control, $option, $flag, $border);
            }
        } else {
            _require_param_type(\$add, ['Wx::Control', 'Wx::Sizer']);
            $sizer->Add($add, $option, $flag, $border);
        }

        return;    # should be void context anyway
    } else {
        my $name = MAGICPREFIX . 'print';
        return Wx::StaticText->new(
            $self->{'_parent'}, wxDefaultID, $add,
            wxDefaultPosition, wxDefaultSize, wxDefaultStyle,
            $name
        );
    }
}


sub param {
    my $self = shift;
    my ($name) = _rearrange([qw(NAME)], @_);
    my (@children);

    _init_param(\$name);

    @children = $self->{'_parent'}->GetChildren();

    if (defined $name) {
        foreach my $child (@children) {
            if ($child->GetName() eq $name) {
                my $data = $self->_get_form_data($child);

                if (ref($data) eq 'ARRAY') {
                    if (wantarray) {
                        return @$data;
                    } else {
                        return $data->[0];
                    }
                } else {
                    return $data;
                }
            }
        }
    } else {
        my $prefix = MAGICPREFIX;
        return grep {!/^$prefix/} map {$_->GetName()} @children;
    }
}


### PRIVATE ###

sub _get_form_data {
    my ($self, $child) = @_;
    my ($value);

    local *isa = \&UNIVERSAL::isa;
    undef $value;

    # XXX: should check if $child->Get* doesn't return a value
    if (isa($child, 'Wx::TextCtrl')) {
        $value = $child->GetValue();
    } elsif (isa($child, 'Wx::Choice')) {
        $value = $child->GetClientData($child->GetSelection());
    } elsif (isa($child, 'Wx::ListBox')) {
        $value = [ $child->GetClientData($child->GetSelections()) ];
    } elsif (isa($child, 'Wx::RadioBox')) {
        $value = $child->GetStringSelection();
    } elsif (isa($child, 'Wx::CheckBox')) {
        $value = $child->GetValue() || '';
    } elsif (isa($child, 'Wx::Button') || isa($child, 'Wx::BitmapButton')) {
        $value = $child->GetLabel();
    }

    return $value;
}

sub _page_width {
    my $self = shift;
    return $self->{'_parent'}->GetSize()->GetWidth();
}

# Does h1, h2, ..., h6
sub _h {
    my $self = shift;
    my ($text, $num) = @_;
    my ($textctrl, $font, $name);

    $name = MAGICPREFIX . "h$num";
    $textctrl = Wx::StaticText->new(
        $self->{'_parent'}, wxDefaultID, $text,
        wxDefaultPosition, wxSIZE($self->_page_width(), wxDefaultHeight),
        wxALIGN_LEFT, $name
    );

    $font = Wx::Font->new(POINTSIZE->{$num}, wxDEFAULT, wxNORMAL, wxBOLD);
    $textctrl->SetFont($font);

    return $textctrl;
}


# Note that the following are not class or object methods.
# There is no $self argument.


# Verify that the variable pointed to by reference $ptr
# is defined (i.e. was given as an argument in
# the calling subroutine. If $$ptr is undef,
# set $$ptr to $default (or undef if $default isn't
# supplied).
sub _init_param {
    my ($ptr, $default) = @_;
    undef $default unless defined $default;
    $$ptr = $default unless defined $$ptr;
}

# Verify that the variable pointed to by reference $ptr is
# an object of class $class. If $$ptr is undef or not an
# object of $class and $default is supplied, set $$ptr
# to $default (or undef if $default isn't supplied).
# Optional $arg is used for named parameters and only
# in the warning message to help with debugging.
sub _init_param_class {
    my ($ptr, $default, $class, $arg) = @_;
    undef $default unless defined $default;
    _init_param(\$arg, '');

    if (defined $$ptr) {
        unless (UNIVERSAL::isa($$ptr, $class)) {
            carp "argument $arg ignored (not a $class)";
            undef $$ptr;
        }
    }
    _init_param($ptr, $default);
}

# Require $$ptr to have been given as an argument
sub _require_param {
    my ($ptr, $arg) = @_;
    _init_param(\$arg, '');

    confess "$arg argument missing" unless defined $$ptr;
}

# Require $$ptr to have been given and to be of type $types.
# $types can be an arrayref, in which case $$ptr has to
# be one of the types in the array.
sub _require_param_type {
    my ($ptr, $types, $arg) = @_;
    _init_param(\$arg, '');

    $types = [$types] unless ref($types) eq 'ARRAY';

    if (defined $$ptr) {
        foreach my $type (@$types) {
            return if UNIVERSAL::isa($$ptr, $type);
        }
    }

    confess "$arg argument invalid (not a '", join(" or '", @$types), "')";
}

sub _no_op {
    # No operation, in case you use something
    # like `start_form' out of habit.
}

# Convenience function for making labels from values
# (for things like popup_menu, radio_group, ...)
sub _make_labels {
    my ($values, $labels) = @_;
    my (@labels);

    foreach my $value (@$values) {
        $labels->{$value} = $value unless defined $labels->{$value};
    }
    for (my $i = 0; $i < @$values; $i++) {
        push @labels, $labels->{$values->[$i]};
    }

    return \@labels;
}

# This is CGI::Util::rearrange, swiped almost directly from CGI.pm.
# If the first parameter begins with '-', it rearranges the
# parameters so that you can use named parameters; otherwise,
# you pass the parameters in order.
# I didn't want to load CGI::Util just for this function,
# plus I removed the part where leftover arguments are
# made into HTML attributes.
sub _rearrange {
    my ($order, @param) = @_;
    my ($i, %pos, @result);

    return () unless @param;

    if (ref($param[0]) eq 'HASH') {
        @param = %{ $param[0] };
    } else {
        return @param
            unless defined($param[0]) && substr($param[0],0,1) eq '-';
    }

    # map parameters into positional indices
    $i = 0;
    foreach (@$order) {
        foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
        $i++;
    }

    $#result = $#$order;  # preextend
    while (@param) {
        my $key = lc(shift(@param));
        $key =~ s/^\-//;
        if (exists $pos{$key}) {
            $result[$pos{$key}] = shift(@param);
        }
    }

    return @result;
}

# Make a Bitmap from a filename
sub _bitmap {
    my $filename = shift;
    my ($type);

    carp "bitmap file not found" unless -r $filename;

    if ($filename =~ /\.bmp$/i) {
        $type = wxBITMAP_TYPE_BMP;
    } elsif ($filename =~ /\.gif$/i) {
        $type = wxBITMAP_TYPE_GIF;
    } elsif ($filename =~ /\.xbm$/i) {
        $type = wxBITMAP_TYPE_XBM;
    } elsif ($filename =~ /\.xpm$/i) {
        $type = wxBITMAP_TYPE_XPM;
    } elsif ($filename =~ /\.jpg$/i || $filename =~ /\.jpeg$/i) {
        $type = wxBITMAP_TYPE_JPEG;
    } elsif ($filename =~ /\.png$/i) {
        $type = wxBITMAP_TYPE_PNG;
    } elsif ($filename =~ /\.pcx$/i) {
        $type = wxBITMAP_TYPE_PCX;
    } elsif ($filename =~ /\.pnm$/i) {
        $type = wxBITMAP_TYPE_PNM;
    } elsif ($filename =~ /\.tif$/i || $filename =~ /\.tiff$/i) {
        $type = wxBITMAP_TYPE_TIF;
    } else {
        undef $type;   # well, we tried
    }

    return Wx::Bitmap->new($filename, $type);
}



1;

__END__