#
# This file is part of Tk-Role-Dialog
#
# This software is copyright (c) 2010 by Jerome Quelin.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use 5.010;
use strict;
use warnings;
package Tk::Role::Dialog;
{
$Tk::Role::Dialog::VERSION = '1.112380';
}
# ABSTRACT: moose role for enhanced tk dialogs
use File::Basename qw{ fileparse };
use Moose::Role 0.92;
use MooseX::Has::Sugar;
use MooseX::Types::Path::Class qw{ File };
use Tk;
use Tk::JPEG;
use Tk::PNG;
use Tk::Sugar;
with 'Tk::Role::HasWidgets' => { -version => 1.112380 }; # _clear_w
# -- accessors
has parent => ( ro, required, weak_ref, isa=>'Tk::Widget' );
has hidden => ( ro, lazy_build, isa=>'Bool' );
has icon => ( ro, lazy_build, isa=>File, coerce );
has title => ( ro, lazy_build, isa=>'Str' );
has header => ( ro, lazy_build, isa=>'Str' );
has text => ( ro, lazy_build, isa=>'Str' );
has image => ( ro, lazy_build, isa=>'Str' );
has resizable => ( ro, lazy_build, isa=>'Bool' );
has ok => ( ro, lazy_build, isa=>'Str' );
has cancel => ( ro, lazy_build, isa=>'Str' );
has hide => ( ro, lazy_build, isa=>'Str' );
has _toplevel => ( rw, lazy_build, isa=>'Tk::Toplevel' );
# -- initialization / finalization
# those are defaults for the role public attributes
sub _build_hidden { 0 }
sub _build_title { 'tk dialog' }
sub _build_icon { '' }
sub _build_header { '' }
sub _build_image { '' }
sub _build_text { '' }
sub _build_resizable { 0 }
sub _build_ok { '' }
sub _build_cancel { '' }
sub _build_hide { '' }
sub _build__toplevel {
my $self = shift;
return $self->parent->Toplevel;
}
#
# BUILD()
#
# called as constructor initialization
#
sub BUILD { }
after BUILD => sub {
my $self = shift;
$self->_build_dialog;
};
# -- gui methods
sub close {
my $self = shift;
$self->_toplevel->destroy;
}
# -- private methods
#
# dialog->_build_dialog;
#
# create the various gui elements.
#
sub _build_dialog {
my $self = shift;
my $top = $self->_toplevel;
$top->withdraw;
if ( $self->icon ) {
my $icon = $top->Photo( -file => $self->icon );
$top->iconimage( $icon );
# transparent images have a xbm mask
my ($file, $path, undef) = fileparse( $self->icon, qr/\.png/i );
my $mask = $path . "$file-mask.xbm";
$top->iconmask( '@' . $mask ) if -f $mask;
}
# dialog name
if ( $self->header ) {
my $font = $top->Font(-size=>16);
$top->Label(
-text => $self->header,
-bg => 'black',
-fg => 'white',
-font => $font,
)->pack(top, pad10, ipad10, fill2);
}
# build inner gui elements
if ( $self->text ) {
my $f = $top->Frame->pack(top, xfill2);
if ( $self->image ) {
my $image = $top->Photo( -file => $self->image );
$f->Label(-image => $image)->pack(left, fill2, pad10);
}
$f->Label(
-text => $self->text,
-justify => 'left',
-wraplength => '8c',
)->pack(left, fill2, pad10);
}
if ( $self->can( '_build_gui' ) ) {
my $f = $top->Frame->pack(top,xfill2);
$self->_build_gui($f);
}
# the dialog buttons.
# note that we specify a bogus width in order for both buttons to be
# the same width. since we pack them with expand set to true, their
# width will grow - but equally. otherwise, their size would be
# proportional to their english text.
my $fbuttons = $top->Frame->pack(top, fillx);
if ( $self->ok ) {
my $but = $fbuttons->Button(
-text => $self->ok,
-width => 10,
-command => sub { $self->_valid },
)->pack(left, xfill2);
$self->_set_w('ok', $but);
$top->bind('<Return>', sub { $self->_valid });
$top->bind('<Escape>', sub { $self->_valid }) unless $self->cancel;
}
if ( $self->hide ) {
my $but = $fbuttons->Button(
-text => $self->hide,
-width => 10,
-command => sub { $top->withdraw },
)->pack(left, xfill2);
$self->_set_w('hide', $but);
$top->bind('<Return>', sub { $top->withdraw }) unless $self->ok;
$top->bind('<Escape>', sub { $top->withdraw }) unless $self->cancel;
}
if ( $self->cancel ) {
my $but = $fbuttons->Button(
-text => $self->cancel,
-width => 10,
-command => sub { $self->close },
)->pack(left, xfill2);
$self->_set_w('cancel', $but);
$top->bind('<Escape>', sub { $self->close });
$top->bind('<Return>', sub { $self->close }) unless $self->ok;
}
# window title
# this should come at the end, since some widgets (i'm looking at
# you tk::pod::text!) change the window title - tsk!
$top->title( $self->title );
# center window & make it appear
$top->Popup( -popover => $self->parent ) unless $self->hidden;
if ( $self->resizable ) {
$top->minsize($top->width, $top->height);
} else {
$top->resizable(0,0);
}
# allow dialogs to finish once everything is in place
$self->_finish_gui if $self->can('_finish_gui');
}
no Moose::Role;
1;
=pod
=head1 NAME
Tk::Role::Dialog - moose role for enhanced tk dialogs
=head1 VERSION
version 1.112380
=head1 SYNOPSIS
package Your::Tk::Dialog::Class;
use Moose;
with 'Tk::Role::Dialog';
sub _build_title { 'window title' }
sub _build_icon { '/path/to/some/icon.png' }
sub _build_header { 'big dialog header' }
sub _build_resizable { 0 }
sub _build_ok { 'frobnize' } # call $self->_valid
sub _build_cancel { 'close' } # close the window
sub _build_gui {
my ($self, $frame) = @_;
# build the inner dialog widgets in the $frame
}
sub _valid {
# called when user clicked the 'ok' button
$self->close;
}
# in your main program
use Your::Tk::Dialog::Class;
# create & show a new dialog
Your::Tk::Dialog::Class->new( parent => $main_window );
=head1 DESCRIPTION
L<Tk::Role::Dialog> is meant to be used as a L<Moose> role to be
composed for easy L<Tk> dialogs creation.
It will create a new toplevel with a title, and possibly a header as
well as some buttons.
One can create the middle part of the dialog by providing a
C<_build_gui()> method, that will receive a L<Tk::Frame> where widgets
are supposed to be placed.
The attributes (see below) can be either defined as defaults using the
C<_build_attr()> methods, or passed arguments to the constructor call.
The only mandatory attribute is C<parent>, but you'd better provide some
other attributes if you want your dialog to be somehow usable! :-)
=head1 ATTRIBUTES
=head2 parent
The parent window of the dialog, required.
=head2 hidden
Whether the dialog should popup or stay hidden after creation. Default
to false, which means the dialog is shown.
=head2 icon
The path to an image to be used as window icon. Default to empty string
(meaning no customized window icon), but not required.
=head2 title
The dialog title, default to C<tk dialog>.
=head2 header
A header (string) to display at the top of the window. Default to empty
string, meaning no header.
=head2 image
The path to an image to be displayed alongside the dialog text. Not
taken into account if C<text> attribute is empty. Default to empty
string, meaning no image.
=head2 text
Some text to be displayed, for simple information dialog boxes. Default
to empty string, meaning dialog is to be filled by providing a
C<_build_gui()> method. Can be combined with an C<image> attribute for
enhanced appearance.
=head2 resizable
A boolean to control whether the dialog can be resized or not (default).
=head2 ok
A string to display as validation button label. Default to empty string,
meaning no validation button. The validation action will call
C<< $self->_valid() >>.
=head2 cancel
A string to display as cancellation button label. Default to empty
string, meaning no cancellation button. The cancel action is to just
close the dialog.
=head2 hide
A string to display as hiding button label. Default to empty
string, meaning no hiding button. The hiding action is to just
hide the dialog (think C<withdraw>).
=head1 METHODS
=head2 close
$dialog->close;
Request to destroy the dialog.
=for Pod::Coverage BUILD
DEMOLISH
=head1 SEE ALSO
You can look for information on this module at:
=over 4
=item * Search CPAN
L<http://search.cpan.org/dist/Tk-Role-Dialog>
=item * See open / report bugs
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Tk-Role-Dialog>
=item * Git repository
L<http://github.com/jquelin/tk-role-dialog>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/Tk-Role-Dialog>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/Tk-Role-Dialog>
=back
=head1 AUTHOR
Jerome Quelin
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by Jerome Quelin.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__