Файловый менеджер - Редактировать - /var/www/html/UI.zip
Ðазад
PK ! 5��C) C) Dialog.podnu ��6�$ =head1 NAME UI::Dialog - wrapper for various dialog applications. =head1 SYNOPSIS use UI::Dialog; my $d = new UI::Dialog ( backtitle => 'Demo', title => 'Default', height => 20, width => 65 , listheight => 5, order => [ 'zenity', 'xdialog' ] ); # Either a Zenity or Xdialog msgbox widget should popup, # with a preference for Zenity. $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog is a OOPerl wrapper for the various dialog applications. These dialog backends are currently supported: Zenity, XDialog, GDialog, KDialog, CDialog, and Whiptail. There is also an ASCII backend provided as a last resort interface for the console based dialog variants. UI::Dialog is a class that provides a strict interface to these various backend modules. By using UI:Dialog (with it's imposed limitations on the widgets) you can ensure that your Perl program will function with any available interfaces. =head1 DESCRIPTION UI::Dialog supports priority ordering of the backend detection process. So if you'd prefer that Xdialog should be used first if available, simply designate the desired order when creating the new object. The default order for detecting and utilization of the backends are as follows: (with DISPLAY env): Zenity, GDialog, XDialog, KDialog (without DISPLAY): CDialog, Whiptail, ASCII UI::Dialog is the result of a complete re-write of the UDPM CPAN module. This was done to break away from the bad choice of name (UserDialogPerlModule) and to implement a cleaner, more detached, OOPerl interface. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 None =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'zenity', 'xdialog', 'gdialog' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<order = [ zenity, xdialog, gdialog, kdialog, cdialog, whiptail, ascii ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =item B<height = \d+> (20) * =item B<width = \d+> (65) * =item B<listheight = \d+> (5) * =item B<trust-input = 0,1> (0) * =back =back =head1 STATE METHODS =head2 state( ) =over 4 =item EXAMPLE =over 6 if ($d->state() eq "OK") { $d->msgbox( text => "that went well" ); } =back =item DESCRIPTION =over 6 Returns the state of the last dialog widget command. The value can be one of "OK", "CANCEL", "ESC". The return data is based on the exit codes (return value) of the last widget displayed. =back =item RETURNS =over 6 a single SCALAR. =back =back =head2 ra( ) =over 4 =item EXAMPLE =over 6 my @array = $d->ra(); =back =item DESCRIPTION =over 6 Returns the last widget's data as an array. =back =item RETURNS =over 6 an ARRAY. =back =back =head2 rs( ) =over 4 =item EXAMPLE =over 6 my $string = $d->rs(); =back =item DESCRIPTION =over 6 Returns the last widget's data as a (possibly multiline) string. =back =item RETURNS =over 6 a SCALAR. =back =back =head2 rv( ) =over 4 =item EXAMPLE =over 6 my $string = $d->rv(); =back =item DESCRIPTION =over 6 Returns the last widget's exit status, aka: return value. =back =item RETURNS =over 6 a SCALAR. =back =back =head1 WIDGET METHODS =head2 yesno( ) =over 4 =item EXAMPLE =over 6 if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, yes and no. =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Please enter some text...', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some hidden text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field, that has hidden input, and a message. Note that the GDialog backend will provide a regular inputbox instead of a password box because gdialog doesn't support passwords. GDialog is on it's way to the proverbial software heaven so this isn't a real problem. Use Zenity instead :) =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection1 = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog::GNOME UI::Dialog::KDE UI::Dialog::Console UI::Dialog::Backend UI::Dialog::Backend::ASCII UI::Dialog::Backend::CDialog UI::Dialog::Backend::GDialog UI::Dialog::Backend::KDialog UI::Dialog::Backend::Nautilus UI::Dialog::Backend::Whiptail UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD UI::Dialog::Backend::Zenity =back =over 2 =item MAN FILES dialog(1), whiptail(1), zenity(1), gdialog(1), Xdialog(1), osd_cat(1), kdialog(1) and nautilus(1) =back =head1 SECURITY While UI::Dialog tries to be secure on your behalf, this is not an easy task and it is advised that you never trust user input when dealing with any libraries (not just UI::Dialog). UI::Dialog does not allow for strings with shell command substitutions by default. This is achived by replacing all instances of back-tick B<`> characters with single-quotes B<'> and if any B<$()> constructs are found, the dollar sign is removed. To disable this behaviour, pass 'trust-input'=>1 into the module constructor or into any dialog function (such as B<menu>). See the B<examples/trust-input.pl> sample code for a demonstration. =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! ���;b b Dialog/GNOME.podnu ��6�$ =head1 NAME UI::Dialog::GNOME - GNOME GUI meta-class for UI::Dialog. =head1 SYNOPSIS use UI::Dialog::GNOME; my $d = new UI::Dialog::GNOME ( title => 'Default title', height => 20, width => 65 , listheight => 5, order => [ 'zenity', 'xdialog' ] ); # Either a Zenity or Xdialog msgbox widget should popup, # with a preference for Zenity. $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::GNOME is simply another meta-class for UI::Dialog. This class simply has a different order of priority than UI::Dialog and no console support. =head1 DESCRIPTION This class is simply a nice way to try and ensure a GNOME based widget set. The editbox() widget is also provided in addition to the standard widgets as both the XDialog and Zenity backends effectively support it's usage. If you are still using GDialog and not Zenity (which provides a very nice gdialog wrapper) the editbox() widget will cause your application to die with a "missing method editbox()" error. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'zenity', 'xdialog', 'gdialog' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::GNOME class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. =over 6 =item B<debug = 0,1,2> (0) =item B<order = [ zenity, xdialog, gdialog ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') =item B<title = "title"> ('') =item B<beepbefore = 0,1> (0) =item B<beepafter = 0,1> (0) =item B<height = \d+> (20) =item B<width = \d+> (65) =item B<listheight = \d+> (5) =back =back =head1 WIDGET METHODS =head2 editbox( ) =over 4 =item EXAMPLE =over 6 $d->editbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with an editable textbox containing the contents of the given text file. =back =item RETURNS =over 6 A SCALAR containing the edited text if the response is OK and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Backend UI::Dialog::Backend::GDialog UI::Dialog::Backend::Nautilus UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD UI::Dialog::Backend::Zenity =back =over 2 =item MAN FILES zenity(1), gdialog(1), Xdialog(1), osd_cat(1) and nautilus(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! *�m�� � Dialog/Gauged.pmnu ��6�$ package UI::Dialog::Gauged; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; BEGIN { use vars qw($VERSION); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = {@_} || {}; my $self = {}; bless($self, $class); $self->{'debug'} = $cfg->{'debug'} || 0; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } if (not $cfg->{'order'} and ($ENV{'DISPLAY'} && length($ENV{'DISPLAY'}) > 0)) { #: Pick a GUI mode 'cause a DISPLAY was detected if ($ENV{'TERM'} =~ /^dumb$/i) { # we're running free of a terminal $cfg->{'order'} = [ 'zenity', 'xdialog' ]; } else { # we're running in a terminal $cfg->{'order'} = [ 'zenity', 'xdialog', 'cdialog', 'whiptail' ]; } } # verify and repair the order $cfg->{'order'} = ((ref($cfg->{'order'}) eq "ARRAY") ? $cfg->{'order'} : ($cfg->{'order'}) ? [ $cfg->{'order'} ] : [ 'cdialog', 'whiptail' ]); $self->_debug("ENV->UI_DIALOGS: ".($ENV{'UI_DIALOGS'}||'NULL'),2); $cfg->{'order'} = [ split(/\:/,$ENV{'UI_DIALOGS'}) ] if $ENV{'UI_DIALOGS'}; $self->_debug("ENV->UI_DIALOG: ".($ENV{'UI_DIALOG'}||'NULL'),2); unshift(@{$cfg->{'order'}},$ENV{'UI_DIALOG'}) if $ENV{'UI_DIALOG'}; $cfg->{'trust-input'} = ( exists $cfg->{'trust-input'} && $cfg->{'trust-input'}==1 ) ? 1 : 0; my @opts = (); foreach my $opt (keys(%$cfg)) { push(@opts,$opt,$cfg->{$opt}); } $self->_debug("order: @{$cfg->{'order'}}",2); if (ref($cfg->{'order'}) eq "ARRAY") { foreach my $try (@{$cfg->{'order'}}) { if ($try =~ /^zenity$/i) { $self->_debug("trying zenity",2); if (eval "require UI::Dialog::Backend::Zenity; 1" && $self->_has_variant('zenity')) { require UI::Dialog::Backend::Zenity; $self->{'_ui_dialog'} = new UI::Dialog::Backend::Zenity (@opts); $self->_debug("using zenity",2); last; } else { next; } } elsif ($try =~ /^(?:xdialog|X)$/i) { $self->_debug("trying xdialog",2); if (eval "require UI::Dialog::Backend::XDialog; 1" && $self->_has_variant('Xdialog')) { require UI::Dialog::Backend::XDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::XDialog (@opts,'XDIALOG_HIGH_DIALOG_COMPAT',1); $self->_debug("using xdialog",2); last; } else { next; } } elsif ($try =~ /^(?:dialog|cdialog)$/i) { $self->_debug("trying cdialog",2); if (eval "require UI::Dialog::Backend::CDialog; 1" && $self->_has_variant('dialog')) { require UI::Dialog::Backend::CDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::CDialog (@opts); $self->_debug("using cdialog",2); last; } else { next; } } elsif ($try =~ /^whiptail$/i) { $self->_debug("trying whiptail",2); if (eval "require UI::Dialog::Backend::Whiptail; 1" && $self->_has_variant('whiptail')) { require UI::Dialog::Backend::Whiptail; $self->{'_ui_dialog'} = new UI::Dialog::Backend::Whiptail (@opts); $self->_debug("using whiptail",2); last; } else { next; } } else { # we don't know what they're asking for... try UI::Dialog... if (eval "require UI::Dialog; 1") { require UI::Dialog; $self->{'_ui_dialog'} = new UI::Dialog (@opts); $self->_debug(ref($self)." unknown backend: '".$try."', using UI::Dialog instead.",2); last; } else { next; } } } } else { carp("Failed to load any suitable dialog variant backend."); } ref($self->{'_ui_dialog'}) or croak("unable to load suitable backend."); return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: #: purely internal usage sub _debug { my $self = $_[0]; my $mesg = $_[1] || 'null error message given!'; my $rate = $_[2] || 1; return() unless $self->{'debug'} and $self->{'debug'} >= $rate; chomp($mesg); print STDERR "Debug: ".$mesg."\n"; } sub _has_variant { my $self = $_[0]; my $variant = $_[1]; $self->{'PATHS'} = ((ref($self->{'PATHS'}) eq "ARRAY") ? $self->{'PATHS'} : ($self->{'PATHS'}) ? [ $self->{'PATHS'} ] : [ '/bin', '/usr/bin', '/usr/local/bin', '/opt/bin' ]); foreach my $PATH (@{$self->{'PATHS'}}) { return($PATH . '/' . $variant) unless not -x $PATH . '/' . $variant; } return(0); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #: dialog variant state methods: sub state { return(shift()->{'_ui_dialog'}->state(@_)); } sub ra { return(shift()->{'_ui_dialog'}->ra(@_)); } sub rs { return(shift()->{'_ui_dialog'}->rs(@_)); } sub rv { return(shift()->{'_ui_dialog'}->rv(@_)); } #: Frills #: all backends support nautilus scripts. sub nautilus { return(shift()->{'_ui_dialog'}->nautilus(@_)); } #: same with osd_cat (aka: xosd). sub xosd { return(shift()->{'_ui_dialog'}->xosd(@_)); } #: Beep & Clear may have no affect when using GUI backends sub beep { return(shift()->{'_ui_dialog'}->beep(@_)); } sub clear { return(shift()->{'_ui_dialog'}->clear(@_)); } #: widget methods: sub yesno { return(shift()->{'_ui_dialog'}->yesno(@_)); } sub msgbox { return(shift()->{'_ui_dialog'}->msgbox(@_)); } sub inputbox { return(shift()->{'_ui_dialog'}->inputbox(@_)); } sub password { return(shift()->{'_ui_dialog'}->password(@_)); } sub textbox { return(shift()->{'_ui_dialog'}->textbox(@_)); } sub menu { return(shift()->{'_ui_dialog'}->menu(@_)); } sub checklist { return(shift()->{'_ui_dialog'}->checklist(@_)); } sub radiolist { return(shift()->{'_ui_dialog'}->radiolist(@_)); } sub fselect { return(shift()->{'_ui_dialog'}->fselect(@_)); } sub dselect { return(shift()->{'_ui_dialog'}->dselect(@_)); } # gauge methods sub gauge_start { return(shift()->{'_ui_dialog'}->gauge_start(@_)); } sub gauge_stop { return(shift()->{'_ui_dialog'}->gauge_stop(@_)); } sub gauge_inc { return(shift()->{'_ui_dialog'}->gauge_inc(@_)); } sub gauge_dec { return(shift()->{'_ui_dialog'}->gauge_dec(@_)); } sub gauge_set { return(shift()->{'_ui_dialog'}->gauge_set(@_)); } sub gauge_text { return(shift()->{'_ui_dialog'}->gauge_text(@_)); } 1; PK ! u��!� � Dialog/Console.podnu ��6�$ =head1 NAME UI::Dialog::Console - console meta-class for UI::Dialog. =head1 SYNOPSIS use UI::Dialog::Console; my $d = new UI::Dialog::Console ( title => 'Default', height => 20, width => 65, listheight => 5 ); # Either a CDialog, Whiptail or ASCII msgbox widget should be displayed # with a preference for CDialog. $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Console is simply another meta-class for UI::Dialog. This class simply has a different order of priority than UI::Dialog and no GUI support. =head1 DESCRIPTION This class is simply a nice way to try and ensure a Console based widget set. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'cdialog', 'whiptail', 'ascii' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Console class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. =over 6 =item B<debug = 0,1,2> (0) =item B<order = [ kdialog, xdialog ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') =item B<title = "title"> ('') =item B<beepbefore = 0,1> (0) =item B<beepafter = 0,1> (0) =item B<height = \d+> (20) =item B<width = \d+> (65) =item B<listheight = \d+> (5) =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Backend UI::Dialog::Backend::ASCII UI::Dialog::Backend::CDialog UI::Dialog::Backend::Whiptail =back =over 2 =item MAN FILES dialog(1), whiptail(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! �w�� � Dialog/Gauged.podnu ��6�$ =head1 NAME UI::Dialog::Gauged - wrapper support of gauge related functions. =head1 SYNOPSIS use UI::Dialog::Gauged; my $d = new UI::Dialog::Gauged ( title => 'Default title', height => 20, width => 65 , listheight => 5, order => [ 'zenity', 'xdialog' ] ); # Either a Zenity or Xdialog msgbox widget should popup, # with a preference for Zenity. $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Gauged is simply another meta-class for UI::Dialog. This class simply has a different order of priority than UI::Dialog and only uses backends that support a standard set of gauge related functions. =head1 DESCRIPTION This class is simply a nice way to try and ensure a GNOME based widget set. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'zenity', 'xdialog' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Gauged class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. =over 6 =item B<debug = 0,1,2> (0) =item B<order = [ zenity, xdialog, cdialog, whiptail ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') =item B<title = "title"> ('') =item B<beepbefore = 0,1> (0) =item B<beepafter = 0,1> (0) =item B<height = \d+> (20) =item B<width = \d+> (65) =item B<listheight = \d+> (5) =back =back =head1 WIDGET METHODS =head2 gauge_start( ) =over 4 =item EXAMPLE =over 6 $d->gauge_start( text => 'gauge...', percentage => 1 ); =back =item DESCRIPTION =over 6 Display a meter bar to the user. This get's the widget realized but requires the use of the other gauge_*() methods for functionality. =back =item RETURNS =over 6 TRUE (1) if the widget loaded fine and FALSE (0) for anything else. =back =back =head2 gauge_inc( ) =over 4 =item EXAMPLE =over 6 $d->gauge_inc( 1 ); =back =item DESCRIPTION =over 6 Increment the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_set( ) =over 4 =item EXAMPLE =over 6 $d->gauge_set( 99 ); =back =item DESCRIPTION =over 6 Set the meter bar to the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_text( ) =over 4 =item EXAMPLE =over 6 $d->gauge_text( 'string' ); =back =item DESCRIPTION =over 6 Set the meter bar message to the given string. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_stop( ) =over 4 =item EXAMPLE =over 6 $d->gauge_stop(); =back =item DESCRIPTION =over 6 End the meter bar widget process. One of the flaws with gdialog is that the gauge widget does not close properly and requies the end user to close the gauge window when 100% has been reached. This is the second reason why I'm glad gdialog is going the way of the dodo. =back =item RETURNS =over 6 TRUE (1) if the widget closed fine and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Backend UI::Dialog::Backend::CDialog UI::Dialog::Backend::Nautilus UI::Dialog::Backend::Whiptail UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD UI::Dialog::Backend::Zenity =back =over 2 =item MAN FILES zenity(1), Xdialog(1), dialog(1), whiptail(1), osd_cat(1) and nautilus(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! ����� � Dialog/Console.pmnu ��6�$ package UI::Dialog::Console; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use UI::Dialog; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = {@_} || {}; my $self = {}; bless($self, $class); $self->{'debug'} = $cfg->{'debug'} || 0; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $cfg->{'order'} ||= [ 'dialog', 'whiptail', 'ascii' ]; $self->_debug("ENV->UI_DIALOGS: ".($ENV{'UI_DIALOGS'}||'NULL'),2); $cfg->{'order'} = [ split(/\:/,$ENV{'UI_DIALOGS'}) ] if $ENV{'UI_DIALOGS'}; $self->_debug("ENV->UI_DIALOG: ".($ENV{'UI_DIALOG'}||'NULL'),2); unshift(@{$cfg->{'order'}},$ENV{'UI_DIALOG'}) if $ENV{'UI_DIALOG'}; $cfg->{'trust-input'} = ( exists $cfg->{'trust-input'} && $cfg->{'trust-input'}==1 ) ? 1 : 0; my @opts = (); foreach my $opt (keys(%$cfg)) { push(@opts,$opt,$cfg->{$opt}); } foreach my $try (@{$cfg->{'order'}}) { if ($try =~ /^(?:cdialog||dialog)$/i) { $self->_debug("trying cdialog",2); if (eval "require UI::Dialog::Backend::CDialog; 1" && $self->_has_variant('dialog')) { require UI::Dialog::Backend::CDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::CDialog (@opts); $self->_debug("using cdialog",2); last; } else { next; } } elsif ($try =~ /^(?:gdialog||gdialog\.real)$/i) { $self->_debug("trying gdialog",2); if (eval "require UI::Dialog::Backend::GDialog; 1" && ($self->_has_variant('gdialog.real') || $self->_has_variant('gdialog'))) { require UI::Dialog::Backend::GDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::GDialog (@opts); $self->_debug("using gdialog",2); last; } else { next; } } elsif ($try =~ /^whiptail$/i) { $self->_debug("trying whiptail",2); if (eval "require UI::Dialog::Backend::Whiptail; 1" && $self->_has_variant('Whiptail')) { require UI::Dialog::Backend::Whiptail; $self->{'_ui_dialog'} = new UI::Dialog::Backend::Whiptail (@opts); $self->_debug("using whiptail",2); last; } else { next; } } elsif ($try =~ /^(?:ascii||native)$/i) { $self->_debug("trying ascii",2); if (eval "require UI::Dialog::Backend::ASCII; 1") { require UI::Dialog::Backend::ASCII; $self->{'_ui_dialog'} = new UI::Dialog::Backend::ASCII (@opts); $self->_debug("using ascii",2); last; } else { next; } } else { # we don't know what they're asking for... try UI::Dialog... if (eval "require UI::Dialog; 1") { require UI::Dialog; $self->{'_ui_dialog'} = new UI::Dialog (@opts); $self->_debug(ref($self)." unknown backend: '".$try."', using UI::Dialog instead.",2); last; } else { next; } } } ref($self->{'_ui_dialog'}) or croak("unable to load suitable backend."); return($self); } 1; PK ! � ܙ~D ~D Dialog/Backend.podnu ��6�$ =head1 NAME UI::Dialog::Backend - simply a collection of primarily internal methods. =head1 SYNOPSIS use UI::Dialog::Backend; BEGIN { use vars qw( @ISA ); @ISA = qw( UI::Dialog::Backend ); } =head1 ABSTRACT UI::Dialog::Backend is simply a collection of primarily internal methods. =head1 DESCRIPTION While this module is inherited by all UI::Dialog backend modules, this module itself is not meant for direct usage. The "STATE METHODS" and "UTILITY METHODS" documentation is applicable to all backends thus rendering the POD for this class more important to the end-programmer than the usage of the class itself. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 None =back =head1 BACKEND EXTENSIONS =head2 nautilus =over 4 =item EXAMPLE =over 6 my @paths = $d->nautilus->paths(); =back =item DESCRIPTION =over 6 This method gives access to the UI::Dialog::Backend::Nautilus class. This will automagically try to load the UI::Dialog::Backend::Nautilus module or it will silently fail. =back =back =head2 xosd =over 4 =item EXAMPLE =over 6 $d->xosd->line( "a line of text on your screen" ); =back =item DESCRIPTION =over 6 This method gives access to the UI::Dialog::Backend::XOSD class. This will automagically try to load the UI::Dialog::Backend::XOSD module or it will silently fail. =back =back =head2 notify_send =over 4 =item EXAMPLE =over 6 $d->notify_send->notify_send( "a line of text on your screen" ); =back =item DESCRIPTION =over 6 This method gives access to the UI::Dialog::Backend::NotifySend class. This will automagically try to load the UI::Dialog::Backend::NotifySend module or it will silently fail. =back =back =head1 STATE METHODS =head2 attr( ) =over 4 =item EXAMPLE =over 6 my $value = $self->attr('listheight'); my $new_value = $d->attr('listheight',5); =back =item DESCRIPTION =over 6 Either sets and returns the value of the desired attribute, or just returns the value of the desired attribute. =back =item RETURNS =over 6 a single SCALAR. =back =back =head2 state( ) =over 4 =item EXAMPLE =over 6 if ($d->state() eq "OK") { # the last user response was "OK" } else { # something other than an "OK" response } =back =item DESCRIPTION =over 6 Returns the state of the last dialog widget command. The value can be one of "OK", "CANCEL" or "ESC". The return data is based on the exit codes (return value) of the last widget displayed. Some backends also support other exit values than the standard few and these are represented as "EXTRA" (3), "HELP" (2), and "ERROR" (255). =back =item RETURNS =over 6 a single SCALAR. =back =back =head2 ra( ) =over 4 =item EXAMPLE =over 6 my @array = $d->ra(); =back =item DESCRIPTION =over 6 Returns the last widget's data as an array. =back =item RETURNS =over 6 an ARRAY. =back =back =head2 rs( ) =over 4 =item EXAMPLE =over 6 my $string = $d->rs(); =back =item DESCRIPTION =over 6 Returns the last widget's data as a (possibly multiline) string. =back =item RETURNS =over 6 a SCALAR. =back =back =head2 rv( ) =over 4 =item EXAMPLE =over 6 my $string = $d->rv(); =back =item DESCRIPTION =over 6 Returns the last widget's exit status, aka: return value. This is the value used when determining the state() of a widget. =back =item RETURNS =over 6 a SCALAR. =back =back =head1 CALLBACK FUNCTIONS =head2 PRE =over 4 =item EXAMPLE =over 6 sub CB_PRE { my $widget_args = shift(); print "Caller: ".$args->{'caller'}."\n"; } my $d = new UI::Dialog ( callbacks => { PRE => \&CB_PRE } ); =back =item DESCRIPTION =over 6 This function recieves a hasref of the current argument values and is called before any widget performs any operations. =back =back =head2 POST =over 4 =item EXAMPLE =over 6 sub CB_POST { my $widget_args = shift(); my $state = shift(); print "Caller: ".$args->{'caller'}.", State: ".$state."\n"; } my $d = new UI::Dialog ( callbacks => { POST => \&CB_POST } ); =back =item DESCRIPTION =over 6 This function recieves a hasref of the current argument values and the one word state indicator (as reported by state()) and is called after all widget operations have been performed (including other callback functions). =back =back =head2 OK =over 4 =item EXAMPLE =over 6 sub CB_OK_FUNC { my $widget_args = shift(); print "Widget caller: ".$args->{'caller'}."\n"; } my $d = new UI::Dialog ( callbacks => { OK => \&CB_OK_FUNC } ); =back =item DESCRIPTION =over 6 This function recieves a hasref of the current argument values and is called when any widget finishes with a state() of "OK" but before the POST callback. =back =back =head2 CANCEL =over 4 =item EXAMPLE =over 6 sub CB_CANCEL { my $widget_args = shift(); print "Caller: ".$args->{'caller'}."\n"; } my $d = new UI::Dialog ( callbacks => { CANCEL => \&CB_CANCEL } ); =back =item DESCRIPTION =over 6 This function recieves a hasref of the current argument values and is called when any widget finishes with a state() of "CANCEL" but before the POST callback. Be forewarned that with respect to the yesno() type widgets, a user response of "NO" is interpreted as "CANCEL" and will execute this function. =back =back =head2 ESC =over 4 =item EXAMPLE =over 6 sub CB_ESC { my $widget_args = shift(); print "Caller: ".$args->{'caller'}."\n"; } my $d = new UI::Dialog ( callbacks => { ESC => \&CB_ESC } ); =back =item DESCRIPTION =over 6 This function recieves a hasref of the current argument values and is called when any widget finishes with a state() of "ESC" but before the POST callback. =back =back =head2 HELP =over 4 =item EXAMPLE =over 6 sub CB_HELP { my $widget_args = shift(); print "Caller: ".$args->{'caller'}."\n"; } my $d = new UI::Dialog ( callbacks => { HELP => \&CB_HELP } ); =back =item DESCRIPTION =over 6 This function recieves a hasref of the current argument values and is called when any widget finishes with a state() of "HELP" but before the POST callback. The user response of "HELP" is not supported by all backends. =back =back =head2 EXTRA =over 4 =item EXAMPLE =over 6 sub CB_EXTRA { my $widget_args = shift(); print "Caller: ".$args->{'caller'}."\n"; } my $d = new UI::Dialog ( callbacks => { EXTRA => \&CB_EXTRA } ); =back =item DESCRIPTION =over 6 This function recieves a hasref of the current argument values and is called when any widget finishes with a state() of "EXTRA" but before the POST callback. The user response of "EXTRA" is not supported by all backends. =back =back =head1 UTILITY METHODS =head2 beep( ) =over 4 =item EXAMPLE =over 6 $d->beep(); =back =item DESCRIPTION =over 6 If the beep(1) application can be found, use it to make a beep sound. Otherwise print "\a" to STDERR which normally is good enough to make some noise. =back =item RETURNS =over 6 TRUE (1) regardless of result. =back =back =head2 clear( ) =over 4 =item EXAMPLE =over 6 $d->clear(); =back =item DESCRIPTION =over 6 Clear the terminal screen via STDOUT and the `clear` command. This method is technically useless for any GUI based dialog variants. =back =item RETURNS =over 6 TRUE (1) regardless of result. =back =back =head2 word_wrap( ) =over 4 =item EXAMPLE =over 6 my @wrapped_text = $d->word_wrap($cols,$indent,$sub_indent,@text); =back =item DESCRIPTION =over 6 Using the Text::Wrap::wrap function, wrap the words in a string (or array of strings). This is primarily used within the _organize_text() method but may be of use to the end-programmer. =back =item RETURNS =over 6 A word-wrapped version of the given text data. =back =back =head2 gen_tempfile_name( ) =over 4 =item EXAMPLE =over 6 my $tempfile = $d->gen_tempfile_name(); =back =item DESCRIPTION =over 6 This method returns a temporary file name generated using one of the following (in order): the File::Temp perl module if detected, the program "mktemp" or an extremely simplistic built-in name generator. =back =item RETURNS =over 6 A temporary file name. =back =back =head2 gen_random_string( ) =over 4 =item EXAMPLE =over 6 my $random_string = $d->gen_random_string(5); =back =item DESCRIPTION =over 6 This will return a string of random (printable) characters of an arbitrary user-definable length (defaults to 5); =back =item RETURNS =over 6 A string of random ASCII characters. =back =back =head1 WIDGET WRAPPER METHODS These methods are common methods to most backends as they do not have native support for the functionality, yet the functionality is achievable by utilizing existing compatible methods. =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $path = $self->fselect( path => $start_path ); =back =item DESCRIPTION =over 6 Using the menu() and msgbox() widgets we can simulate a file browser interface. Note: to select a directory, go into it and then pick the '.' entry. =back =item RETURNS =over 6 a SCALAR for positive results and FALSE (0) for everything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $path = $self->dselect( path => $start_path ); =back =item DESCRIPTION =over 6 Using the fselect() widget we can simulate a directory browser interface. Note: to select a directory, go into it and then pick the '.' entry. =back =item RETURNS =over 6 a SCALAR for positive results and FALSE (0) for everything else. =back =back =head1 BACKEND METHODS These methods are only necessary for someone wishing to create more UI::Dialog::Backend:: Modules. These are never needed to be directly used but are none the less documented here for reference purposes. =head2 command_state( ) =over 4 =item EXAMPLE =over 6 if ($self->command_state("/some/shell/command")) { #: command succeeded } else { #: command failed } =back =item DESCRIPTION =over 6 This will execute the given command and send STDOUT and STDERR to /dev/null then analyse the exit code and return accordingly. =back =item RETURNS =over 6 TRUE (1) for positive results and FALSE (0) for anything else. =back =back =head2 command_string( ) =over 4 =item EXAMPLE =over 6 my ($rv,$scalar) = $self->command_string("/some/shell/command"); if ($rv >= 1) { #: command failed } else { #: command succeeded print "The command results: ".$scalar."\n"; } =back =item DESCRIPTION =over 6 This will execute the given command, catch STDOUT and STDERR, then return the SCALAR data. =back =item RETURNS =over 6 a SCALAR for positive results and FALSE (0) for anything else. =back =back =head2 command_array( ) =over 4 =item EXAMPLE =over 6 my ($rv,@array) = $self->command_array("/some/shell/command"); if ($rv >= 1) { #: command failed } else { #: command succeeded foreach my $line_of_output (@array) { print "The command results: ".$line_of_output."\n"; } } =back =item DESCRIPTION =over 6 This will execute the given command, catch STDOUT and STDERR, then return the data, split by newlines, as an ARRAY. =back =item RETURNS =over 6 an ARRAY for positive results and FALSE (0) for anything else. =back =back =head2 _pre( ) =over 4 =item EXAMPLE =over 6 my $args = $self->_pre(@_); =back =item DESCRIPTION =over 6 This will use _merge_attrs(), perform any pre-widget-exec things and then return the current argument list as a hashref. This is used in every widget before anything is actually done in the widget and is responsible for running the optional callback function labelled "PRE". =back =item RETURNS =over 6 a HASHREF. =back =back =head2 _post( ) =over 4 =item EXAMPLE =over 6 $self->_post( $args ); =back =item DESCRIPTION =over 6 This method is used in every widget after all operations (for the immediate widget call) are complete but before the widget actually returns anything. This method is responsible for running the optional callback funcions labelled "OK", "ESC", "CANCEL" and "POST" with "POST" being executed absolutely last. =back =item RETURNS =over 6 Nothing. =back =back =head2 _merge_attrs( ) =over 4 =item EXAMPLE =over 6 my $args = $self->_merge_attrs(@_); =back =item DESCRIPTION =over 6 This will apply the arguments passed in with the defaults stored in $self->{'_opts'} (which was instantiated upon object construction). The return result is the "current" options as defined by the defaults with the argument options overriding them. =back =item RETURNS =over 6 a HASHREF. =back =back =head2 _find_bin( ) =over 4 =item EXAMPLE =over 6 my $ZenityBinaryPath = $self->_find_bin('zenity'); =back =item DESCRIPTION =over 6 This will look in the default path directories for the program of the given name. The default PATH list is: /bin, /usr/bin, /usr/local/bin, /opt/bin. =back =item RETURNS =over 6 a SCALAR. =back =back =head2 _esc_text( ) =over 4 =item EXAMPLE =over 6 my $escaped_text = $self->_esc_text( $raw_text ); =back =item DESCRIPTION =over 6 This will escape the following with a prefixing '\' character: Character -> Escaped " \" ` \` ( \( ) \) [ \[ ] \] { \} } \} $ \$ < \< > \> =back =item RETURNS =over 6 an SCALAR for positive results and FALSE (0) for anything else. =back =back =head2 _strip_text( ) =over 4 =item EXAMPLE =over 6 my $clean_text = $self->_strip_text( $text_with_markup ); =back =item DESCRIPTION =over 6 This will strip various markup sequences from within the given argument data. =back =item RETURNS =over 6 an SCALAR for positive results and FALSE (0) for anything else. =back =back =head2 _organize_text( ) =over 4 =item EXAMPLE =over 6 my $final_text1 = $self->_organize_text( $text_with_markup ); my $final_text2 = $self->_organize_text( \@text_with_markup ); =back =item DESCRIPTION =over 6 This will strip various markup sequences from within the given argument data. =back =item RETURNS =over 6 a SCALAR for positive results and FALSE (0) for anything else. =back =back =head2 _is_bsd( ) =over 4 =item EXAMPLE =over 6 if ($self->_is_bsd()) { # do something with BSD specific characteristics } else { # do something with general perl characteristics } =back =item DESCRIPTION =over 6 This simply checks (case-insensitively) the perlvar $^0 for the string "bsd". =back =item RETURNS =over 6 TRUE (1) for positive results and FALSE (0) for anything else. =back =back =head2 _list_dir( ) =over 4 =item EXAMPLE =over 6 my $menu_list = $self->_list_dir( '/some/path/to/a/directory', [ 'optional', 'prefix', 'items' ] ); =back =item DESCRIPTION =over 6 Gather a list of the contents of a directory and forumlate a list suitable for use with most (if not all) file/path selection dialog variant widgets. An optional array reference will have all elements prefixing the directory list. =back =item RETURNS =over 6 an ARRAYREF for positive results and FALSE (0) for anything else. =back =back =head2 _debug( ) =over 4 =item EXAMPLE =over 6 $self->_debug( $debuging_message_string, $debuging_level ); =back =item DESCRIPTION =over 6 This method will print to STDERR the debugging message provided if and only if the debuging level is greater than or equal to the $debuging_level. The debugging level argument is optional and defaults to a level of 1. =back =item RETURNS =over 6 TRUE (1) for positive results and FALSE (0) for anything else. =back =back =head2 _error( ) =over 4 =item EXAMPLE =over 6 $self->_error( $error_message_string ); =back =item DESCRIPTION =over 6 This method will print to STDERR the error message provided regardless of debugging level. =back =item RETURNS =over 6 TRUE (1) for positive results and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Console UI::Dialog::GNOME UI::Dialog::KDE UI::Dialog::Backend::ASCII UI::Dialog::Backend::CDialog UI::Dialog::Backend::GDialog UI::Dialog::Backend::KDialog UI::Dialog::Backend::Nautilus UI::Dialog::Backend::Whiptail UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD UI::Dialog::Backend::Zenity =back =over 2 =item MAN FILES dialog(1), whiptail(1), zenity(1), gdialog(1), Xdialog(1), kdialog(1), nautilus(1) and osd_cat(1). =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! Y��� � Dialog/GNOME.pmnu ��6�$ package UI::Dialog::GNOME; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use UI::Dialog; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = {@_} || {}; my $self = {}; bless($self, $class); $self->{'debug'} = $cfg->{'debug'} || 0; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $cfg->{'order'} ||= [ 'zenity', 'xdialog', 'gdialog' ]; $self->_debug("ENV->UI_DIALOGS: ".($ENV{'UI_DIALOGS'}||'NULL'),2); $cfg->{'order'} = [ split(/\:/,$ENV{'UI_DIALOGS'}) ] if $ENV{'UI_DIALOGS'}; $self->_debug("ENV->UI_DIALOG: ".($ENV{'UI_DIALOG'}||'NULL'),2); unshift(@{$cfg->{'order'}},$ENV{'UI_DIALOG'}) if $ENV{'UI_DIALOG'}; $cfg->{'trust-input'} = ( exists $cfg->{'trust-input'} && $cfg->{'trust-input'}==1 ) ? 1 : 0; my @opts = (); foreach my $opt (keys(%$cfg)) { push(@opts,$opt,$cfg->{$opt}); } foreach my $try (@{$cfg->{'order'}}) { if ($try =~ /^zenity$/i) { $self->_debug("trying zenity",2); if (eval "require UI::Dialog::Backend::Zenity; 1" && $self->_has_variant('zenity')) { require UI::Dialog::Backend::Zenity; $self->{'_ui_dialog'} = new UI::Dialog::Backend::Zenity (@opts); $self->_debug("using zenity",2); last; } else { next; } } elsif ($try =~ /^(?:gdialog|gdialog\.real)$/i) { $self->_debug("trying gdialog",2); if (eval "require UI::Dialog::Backend::GDialog; 1" && ($self->_has_variant('gdialog.real') || $self->_has_variant('gdialog'))) { require UI::Dialog::Backend::GDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::GDialog (@opts); $self->_debug("using gdialog",2); last; } else { next; } } elsif ($try =~ /^(?:xdialog|X)$/i) { $self->_debug("trying xdialog",2); if (eval "require UI::Dialog::Backend::XDialog; 1" && $self->_has_variant('Xdialog')) { require UI::Dialog::Backend::XDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::XDialog (@opts,'XDIALOG_HIGH_DIALOG_COMPAT',1); $self->_debug("using xdialog",2); last; } else { next; } } else { # we don't know what they're asking for... try UI::Dialog... if (eval "require UI::Dialog; 1") { require UI::Dialog; $self->{'_ui_dialog'} = new UI::Dialog (@opts); $self->_debug(ref($self)." unknown backend: '".$try."', using UI::Dialog instead.",2); last; } else { next; } } } ref($self->{'_ui_dialog'}) or croak("unable to load suitable backend."); return($self); } sub editbox { return(shift()->{'_ui_dialog'}->editbox(@_)); } 1; PK ! ��$7 7 Dialog/KDE.podnu ��6�$ =head1 NAME UI::Dialog::KDE - KDE GUI meta-class for UI::Dialog. =head1 SYNOPSIS use UI::Dialog::KDE; my $d = new UI::Dialog::KDE ( backtitle => 'Demo', title => 'Default', height => 20, width => 65 , listheight => 5 ); # Either a KDialog or Xdialog msgbox widget should popup, # with a preference for KDialog. $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::KDE is simply another meta-class for UI::Dialog. This class simply has a different order of priority than UI::Dialog and no console support. =head1 DESCRIPTION This class is simply a nice way to try and ensure a KDE based widget set. KDialog is the only kde dialog variant and as such, XDialog is the only alternative. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'kdialog', 'xdialog' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::KDE class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. =over 6 =item B<debug = 0,1,2> (0) =item B<order = [ kdialog, xdialog ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') =item B<title = "title"> ('') =item B<beepbefore = 0,1> (0) =item B<beepafter = 0,1> (0) =item B<height = \d+> (20) =item B<width = \d+> (65) =item B<listheight = \d+> (5) =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Backend UI::Dialog::Backend::KDialog UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD =back =over 2 =item MAN FILES kdialog(1), osd_cat(1) and Xdialog(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! �9" T' T' Dialog/Backend/Zenity.podnu ��6�$ =head1 NAME UI::Dialog::Backend::Zenity - wrapper of the Zenity application. =head1 SYNOPSIS use UI::Dialog::Backend::Zenity; my $d = new UI::Dialog::Backend::Zenity ( backtitle => 'Demo', title => 'Default' ); $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT Zenity is the speedy, slick, and ultimately cool GTK2 dialog variant that is destined to obselete the current GNOME dialog variant; GDialog. This is an OOPerl wrapper of the Zenity application. =head1 DESCRIPTION UI::Dialog::Backend::Zenity is the UI::Dialog backend for the new GNOME dialog variant. While this module is used through UI::Dialog or any other loader module only the compatible methods are ever accessible. However, when using this module directly in your application (as in the SYNOPSIS example) you are given access to all the options and features of the real zenity(1) application. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5 ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::Zenity class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<literal = 0,1> (0) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<height = \d+> (0) * =item B<width = \d+> (0) * =item B<display = ":0"> ('') * =item B<name = "wmname"> ('') * =item B<class = "wmclass"> ('') * =item B<beepbin = "/usr/bin/beep"> ('') =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =back =back =head1 WIDGET METHODS =head2 yesno( ) question( ) =over 4 =item EXAMPLE =over 6 if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, OK and CANCEL (aka: Yes and No). yesno() is a wrapper for question(). =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some (hidden) text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field that doesn't reveal the input (except to the script) and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Please enter some text...', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 editbox( ) =over 4 =item EXAMPLE =over 6 $d->editbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with an editable textbox containing the contents of the given text file. =back =item RETURNS =over 6 A SCALAR containing the edited text if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 calendar( ) =over 4 =item EXAMPLE =over 6 my $date = $d->calendar( day => 10, month => 10, year => 1977, 'date-format' => '%d/%m/%y' ); =back =item DESCRIPTION =over 6 Present the user with a calendar so that they may select a date. The 'date-format' option follows the same format definition as the date(1) command line program. If the day, month and year options are not provided, the widget defaults to the current date. The default format for the date string is '%d/%m/%y' which breaks down to: "dd/mm/yy". =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 gauge_start( ) =over 4 =item EXAMPLE =over 6 $d->gauge_start( text => 'gauge...', percentage => 1 ); =back =item DESCRIPTION =over 6 Display a meter bar to the user. This get's the widget realized but requires the use of the other gauge_*() methods for functionality. =back =item RETURNS =over 6 TRUE (1) if the widget loaded fine and FALSE (0) for anything else. =back =back =head2 gauge_inc( ) =over 4 =item EXAMPLE =over 6 $d->gauge_inc( 1 ); =back =item DESCRIPTION =over 6 Increment the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_dec( ) =over 4 =item EXAMPLE =over 6 $d->gauge_dec( 1 ); =back =item DESCRIPTION =over 6 Decrement the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_set( ) =over 4 =item EXAMPLE =over 6 $d->gauge_set( 99 ); =back =item DESCRIPTION =over 6 Set the meter bar to the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_stop( ) =over 4 =item EXAMPLE =over 6 $d->gauge_stop(); =back =item DESCRIPTION =over 6 End the meter bar widget process. =back =item RETURNS =over 6 TRUE (1) if the widget closed fine and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::GNOME UI::Dialog::Backend UI::Dialog::Backend::Nautilus UI::Dialog::Backend::XOSD =back =over 2 =item MAN FILES zenity(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! t��� Dialog/Backend/Nautilus.pmnu ��6�$ package UI::Dialog::Backend::Nautilus; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use UI::Dialog::Backend; use FileHandle; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $self = {}; bless($self, $class); $self->{'_opts'}->{'bin'} ||= $self->_find_bin('nautilus'); $self->{'_opts'}->{'bin'} ||= $self->_find_bin('caja'); unless (-x $self->{'_opts'}->{'bin'}) { croak("the nautilus binary could not be found at: ".$self->{'_opts'}->{'bin'}); } return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Internal Methods #: sub _debug { my $self = shift(); my $mesg = shift() || 'unknown msg'; my $logfile = '/tmp/nautilus_debug.tmp'; if (open(NAUTILUSLOGFILE,">>".$logfile)) { print NAUTILUSLOGFILE $mesg."\n"; close(NAUTILUSLOGFILE); } } sub _is_env { my $self = shift(); return(1) unless not $ENV{'NAUTILUS_SCRIPT_SELECTED_FILE_PATHS'} and not $ENV{'NAUTILUS_SCRIPT_SELECTED_URIS'} and not $ENV{'NAUTILUS_SCRIPT_CURRENT_URI'} and not $ENV{'NAUTILUS_SCRIPT_WINDOW_GEOMETRY'}; return(0); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public (Nautilus Shell Script) Methods #: #: Thanks to URI::Escape. Because it's not part of the core Perl, we need to #: include it here. UI::Dialog shouldn't force other dependancies. This version #: is modified to strip the prefixing protocol indicator. sub uri_unescape { # Note from RFC1630: "Sequences which start with a percent sign # but are not followed by two hexadecimal characters are reserved # for future extension" my $self = shift(); my $str = shift(); if (@_ && wantarray) { # not executed for the common case of a single argument my @str = ($str, @_); # need to copy foreach (@str) { s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; s!^\w+\://!!; } return(@str); } $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str; $str =~ s!^\w+\://!!; return($str); } #NAUTILUS_SCRIPT_SELECTED_FILE_PATHS: newline-delimited paths for selected files (only if local) sub paths { my $self = shift(); if ($self->_is_env()) { return(split(/\n/,$ENV{'NAUTILUS_SCRIPT_SELECTED_FILE_PATHS'})) unless not $ENV{'NAUTILUS_SCRIPT_SELECTED_FILE_PATHS'}; my @paths = (); foreach my $uri ($self->uris()) { my $path = $uri; my $desktop = $self->_get_desktop_dir(); $path =~ s!^x\-nautilus\-desktop\:///trash!$ENV{'HOME'}/.Trash!; $path =~ s!^x\-nautilus\-desktop\://!$desktop!; push(@paths,$self->uri_unescape($path)); } return(@paths); } else { return(0); } } #NAUTILUS_SCRIPT_SELECTED_URIS: newline-delimited URIs for selected files sub uris { my $self = shift(); if ($self->_is_env()) { return(split(/\n/,$ENV{'NAUTILUS_SCRIPT_SELECTED_URIS'})); } else { return(0); } } #NAUTILUS_SCRIPT_CURRENT_URI: URI for current location sub path { my $self = shift(); return('error') unless $self->_is_env(); my $URI = $ENV{'NAUTILUS_SCRIPT_CURRENT_URI'} || ''; my $desktop = $self->_get_desktop_dir(); $URI =~ s!^x\-nautilus\-desktop\:///trash!$ENV{'HOME'}/.Trash!; $URI =~ s!^x\-nautilus\-desktop\://!$desktop!; return(($self->uri_unescape($URI)||$URI)); } #NAUTILUS_SCRIPT_CURRENT_URI: URI for current location sub uri { my $self = shift(); return($ENV{'NAUTILUS_SCRIPT_CURRENT_URI'}) if $self->_is_env(); return(0); } #NAUTILUS_SCRIPT_WINDOW_GEOMETRY: position and size of current window sub geometry { my $self = shift(); if ($self->_is_env()) { #: Width, Height, X, Y return($1,$2,$3,$4) if $ENV{'NAUTILUS_SCRIPT_WINDOW_GEOMETRY'} =~ /(\d+)x(\d+)\+(\d+)\+(\d+)/; } else { return(0,0,0,0); } } sub _get_desktop_dir { my $self = shift(); # Figure out the user's home directory my @user = getpwuid($>); my $home = undef; if (@user > 7 && -d $user[7]) { $home = $user[7]; } # check for XDG paths to home directory my $xdg_desktop_dir = $ENV{XDG_DESKTOP_DIR} || undef; if (defined $xdg_desktop_dir && -d $xdg_desktop_dir) { return $xdg_desktop_dir; } my $xdg_config_home = $ENV{XDG_CONFIG_HOME} || $home.'/.config'; if (-d $xdg_config_home && -f $xdg_config_home.'/user-dirs.dirs') { foreach (`. "${xdg_config_home}/user-dirs.dirs"; env`) { chomp; next unless /=/; my ($var, $value) = split(/=/, $_); $ENV{$var} = $value; } } $xdg_desktop_dir = $ENV{XDG_DESKTOP_DIR} || undef; if (defined $xdg_desktop_dir && -d $xdg_desktop_dir) { return $xdg_desktop_dir; } return $home."/Desktop" if -d $home."/Desktop"; # finally defaulting to just home return $home; } 1; PK ! �����s �s Dialog/Backend/CDialog.pmnu ��6�$ package UI::Dialog::Backend::CDialog; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use Config; use FileHandle; use Cwd qw( abs_path ); use Time::HiRes qw( sleep ); use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_state'} = {}; $self->{'_opts'} = {}; #: Dynamic path discovery... my $path_sep = $Config::Config{path_sep}; my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!$path_sep!) { $self->{'PATHS'} = [ split(/$path_sep/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/$path_sep/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'literal'} = $cfg->{'literal'} || 0; $self->{'_opts'}->{'callbacks'} = $cfg->{'callbacks'} || undef(); $self->{'_opts'}->{'timeout'} = $cfg->{'timeout'} || 0; $self->{'_opts'}->{'wait'} = $cfg->{'wait'} || 0; $self->{'_opts'}->{'debug'} = $cfg->{'debug'} || undef(); $self->{'_opts'}->{'title'} = $cfg->{'title'} || undef(); $self->{'_opts'}->{'backtitle'} = $cfg->{'backtitle'} || undef(); $self->{'_opts'}->{'width'} = $cfg->{'width'} || 65; $self->{'_opts'}->{'height'} = $cfg->{'height'} || 10; $self->{'_opts'}->{'percentage'} = $cfg->{'percentage'} || 1; $self->{'_opts'}->{'colours'} = ($cfg->{'colours'} || $cfg->{'colors'}) ? 1 : 0; $self->{'_opts'}->{'bin'} ||= $self->_find_bin('dialog'); $self->{'_opts'}->{'bin'} ||= $self->_find_bin('dialog.exe') if $^O =~ /win32/i; $self->{'_opts'}->{'autoclear'} = $cfg->{'autoclear'} || 0; $self->{'_opts'}->{'clearbefore'} = $cfg->{'clearbefore'} || 0; $self->{'_opts'}->{'clearafter'} = $cfg->{'clearafter'} || 0; $self->{'_opts'}->{'beepbin'} = $cfg->{'beepbin'} || $self->_find_bin('beep') || '/usr/bin/beep'; $self->{'_opts'}->{'beepbefore'} = $cfg->{'beepbefore'} || 0; $self->{'_opts'}->{'beepafter'} = $cfg->{'beepafter'} || 0; unless (-x $self->{'_opts'}->{'bin'}) { croak("the dialog binary could not be found at: ".$self->{'_opts'}->{'bin'}); } $self->{'_opts'}->{'DIALOGRC'} = $cfg->{'DIALOGRC'} || undef(); my $beginref = $cfg->{'begin'}; $self->{'_opts'}->{'begin'} = (ref($beginref) eq "ARRAY") ? $beginref : undef(); $self->{'_opts'}->{'cancel-label'} = $cfg->{'cancel-label'} || undef(); $self->{'_opts'}->{'defaultno'} = $cfg->{'defaultno'} || 0; $self->{'_opts'}->{'default-item'} = $cfg->{'default-item'} || undef(); $self->{'_opts'}->{'exit-label'} = $cfg->{'exit-label'} || undef(); $self->{'_opts'}->{'extra-button'} = $cfg->{'extra-button'} || 0; $self->{'_opts'}->{'extra-label'} = $cfg->{'extra-label'} || undef(); $self->{'_opts'}->{'help-button'} = $cfg->{'help-button'} || 0; $self->{'_opts'}->{'help-label'} = $cfg->{'help-label'} || undef(); $self->{'_opts'}->{'max-input'} = $cfg->{'max-input'} || 0; $self->{'_opts'}->{'no-cancel'} = $cfg->{'no-cancel'} || $cfg->{'nocancel'} || 0; $self->{'_opts'}->{'no-collapse'} = $cfg->{'no-collapse'} || 0; $self->{'_opts'}->{'no-shadow'} = $cfg->{'no-shadow'} || 0; $self->{'_opts'}->{'ok-label'} = $cfg->{'ok-label'} || undef(); $self->{'_opts'}->{'shadow'} = $cfg->{'shadow'} || 0; $self->{'_opts'}->{'tab-correct'} = $cfg->{'tab-correct'} || 0; $self->{'_opts'}->{'tab-len'} = $cfg->{'tab-len'} || 0; $self->{'_opts'}->{'listheight'} = $cfg->{'listheight'} || $cfg->{'menuheight'} || 5; $self->{'_opts'}->{'formheight'} = $cfg->{'formheight'} || $cfg->{'listheight'} || 5; $self->{'_opts'}->{'yes-label'} = $cfg->{'yes-label'} || undef(); $self->{'_opts'}->{'no-label'} = $cfg->{'no-label'} || undef(); $self->{'_opts'}->{'trust-input'} = $cfg->{'trust-input'} || 0; $self->_determine_dialog_variant(); $self->{'test_mode'} = $cfg->{'test_mode'} if exists $cfg->{'test_mode'}; $self->{'test_mode_result'} = ''; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: sub _determine_dialog_variant { my $self = $_[0]; my $str = `$self->{'_opts'}->{'bin'} --help 2>&1`; if ($str =~ /version\s0\.[34]/m) { # this version does not support colours, so far just FreeBSD 4.8 has this # ancient binary. Bugreport from Jeroen Bulten indicates that he's # got a version 0.3 (patched to 0.4) installed. ugh... $self->{'_variant'} = "dialog"; # the separate-output option seems to be the culprit of FreeBSD failure. $self->{'_opts'}->{'force-no-separate-output'} = 1; } elsif ($str =~ /cdialog\s\(ComeOn\sDialog\!\)\sversion\s(\d+\.\d+.+)/) { # We consider cdialog to be a colour supporting dialog variant all others # are non-colourized and support only the base functionality :( my $ver = $1; if ($ver =~ /-20(?:0[3-9]|\d\d)/) { $self->{'_variant'} = "cdialog"; # these versions support colours :) $self->{'_opts'}->{'colours'} = 1; } else { $self->{'_variant'} = "dialog"; } } else { $self->{'_variant'} = "dialog"; } undef($str); } my $SIG_CODE = {}; sub _del_gauge { my $CODE = $SIG_CODE->{$$}; unless (not ref($CODE)) { delete($CODE->{'_GAUGE'}); $CODE->rv('1'); $CODE->rs('null'); $CODE->ra('null'); $SIG_CODE->{$$} = ""; } } sub append_format_base { my ($self,$args,$fmt) = @_; $ENV{'DIALOGRC'} ||= ($args->{'DIALOGRC'} && -r $args->{'DIALOGRC'}) ? $args->{'DIALOGRC'} : ""; $ENV{'DIALOG_CANCEL'} = '1'; $ENV{'DIALOG_ERROR'} = '254'; $ENV{'DIALOG_ESC'} = '255'; $ENV{'DIALOG_EXTRA'} = '3'; $ENV{'DIALOG_HELP'} = '2'; $ENV{'DIALOG_OK'} = '0'; $fmt = $self->append_format_check($args,$fmt,'backtitle','--backtitle {{backtitle}}'); $fmt = $self->append_format_check($args,$fmt,"defaultno","--defaultno"); $fmt = $self->append_format_check($args,$fmt,"extra-button","--extra-button"); $fmt = $self->append_format_check($args,$fmt,"help-button","--help-button"); $fmt = $self->append_format_check($args,$fmt,"no-cancel","--no-cancel"); $fmt = $self->append_format_check($args,$fmt,"no-collapse","--no-collapse"); $fmt = $self->append_format_check($args,$fmt,"no-shadow","--no-shadow"); $fmt = $self->append_format_check($args,$fmt,"shadow","--shadow"); $fmt = $self->append_format_check($args,$fmt,"tab-correct","--tab-correct"); $fmt = $self->append_format_check($args,$fmt,"cancel-label","--cancel-label {{cancel-label}}"); $fmt = $self->append_format_check($args,$fmt,"default-item","--default-item {{default-item}}"); $fmt = $self->append_format_check($args,$fmt,"exit-label","--exit-label {{exit-label}}"); $fmt = $self->append_format_check($args,$fmt,"extra-label","--extra-label {{extra-label}}"); $fmt = $self->append_format_check($args,$fmt,"help-label","--help-label {{help-label}}"); $fmt = $self->append_format_check($args,$fmt,"max-input","--max-input {{max-input}}"); $fmt = $self->append_format_check($args,$fmt,"ok-label","--ok-label {{ok-label}}"); $fmt = $self->append_format_check($args,$fmt,"tab-len","--tab-len {{tab-len}}"); $fmt = $self->append_format_check($args,$fmt,"yes-label","--yes-label {{yes-label}}"); $fmt = $self->append_format_check($args,$fmt,"no-label","--no-label {{no-label}}"); if ($self->{'_opts'}->{'force-no-separate-output'}) { delete $args->{'separate-output'}; } else { $fmt = $self->append_format_check($args,$fmt,"separate-output","--separate-output"); } if ($self->is_cdialog()) { $fmt = $self->append_format($fmt,'--colors'); $fmt = $self->append_format($fmt,'--cr-wrap'); if (exists $args->{'begin'}) { my $begin = $args->{'begin'}; if (ref($begin) eq "ARRAY") { $fmt = $self->append_format($fmt,'--begin '.$begin->[0].' '.$begin->[1]); } } } return $fmt; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Override Inherited Methods #: sub _organize_text { my $self = $_[0]; my $text = $_[1] || return(); my $width = $_[2] || 65; my $trust = (exists $_[3] && defined $_[3]) ? $_[3] : '0'; my @array; if (ref($text) eq "ARRAY") { push(@array,@{$text}); } elsif ($text =~ /\\n/) { @array = split(/\\n/,$text); } else { @array = split(/\n/,$text); } $text = undef(); @array = $self->word_wrap($width,"","",@array); my $max = @array; for (my $i = 0; $i < $max; $i++) { $self->clean_format($trust,\$array[$i]); } if ($self->{'scale'}) { foreach my $line (@array) { my $s_line = $line; #$self->__TRANSLATE_CLEAN($line); $s_line =~ s!\[A\=\w+\]!!gi; $self->{'width'} = length($s_line) + 5 if ($self->{'width'} - 5) < length($s_line) && (length($s_line) <= $self->{'max-scale'}); } } my $new_line = $^O =~ /win32/i ? '\n' : "\n"; foreach my $line (@array) { my $pad; my $s_line = $self->_strip_text($line); if ($line =~ /\[A\=(\w+)\]/i) { my $align = $1; $line =~ s!\[A\=\w+\]!!gi; if (uc($align) eq "CENTER" || uc($align) eq "C") { $pad = ((($self->{'_opts'}->{'width'} - 5) - length($s_line)) / 2); } elsif (uc($align) eq "LEFT" || uc($align) eq "L") { $pad = 0; } elsif (uc($align) eq "RIGHT" || uc($align) eq "R") { $pad = (($self->{'_opts'}->{'width'} - 5) - length($s_line)); } } if ($pad) { $text .= (" " x $pad).$new_line; } else { $text .= $line . $new_line; } } chomp($text); return($self->_filter_text($text)); } sub _strip_text { my $self = shift(); my $text = shift(); $text =~ s!\\Z0!!gmi; $text =~ s!\\Z1!!gmi; $text =~ s!\\Z2!!gmi; $text =~ s!\\Z3!!gmi; $text =~ s!\\Z4!!gmi; $text =~ s!\\Z5!!gmi; $text =~ s!\\Z6!!gmi; $text =~ s!\\Z7!!gmi; $text =~ s!\\Zb!!gmi; $text =~ s!\\ZB!!gmi; $text =~ s!\\Zu!!gmi; $text =~ s!\\ZU!!gmi; $text =~ s!\\Zr!!gmi; $text =~ s!\\ZR!!gmi; $text =~ s!\\Zn!!gmi; $text =~ s!\[C=black\]!!gmi; $text =~ s!\[C=red\]!!gmi; $text =~ s!\[C=green\]!!gmi; $text =~ s!\[C=yellow\]!!gmi; $text =~ s!\[C=blue\]!!gmi; $text =~ s!\[C=magenta\]!!gmi; $text =~ s!\[C=cyan\]!!gmi; $text =~ s!\[C=white\]!!gmi; $text =~ s!\[B\]!!gmi; $text =~ s!\[/B\]!!gmi; $text =~ s!\[U\]!!gmi; $text =~ s!\[/U\]!!gmi; $text =~ s!\[R\]!!gmi; $text =~ s!\[/R\]!!gmi; $text =~ s!\[N\]!!gmi; $text =~ s!\[A=\w+\]!!gmi; return($text); } sub _filter_text { my $self = shift(); my $text = shift() || return(); if ($self->is_cdialog() && $self->{'_opts'}->{'colours'}) { $text =~ s!\[C=black\]!\\Z0!gmi; $text =~ s!\[C=red\]!\\Z1!gmi; $text =~ s!\[C=green\]!\\Z2!gmi; $text =~ s!\[C=yellow\]!\\Z3!gmi; $text =~ s!\[C=blue\]!\\Z4!gmi; $text =~ s!\[C=magenta\]!\\Z5!gmi; $text =~ s!\[C=cyan\]!\\Z6!gmi; $text =~ s!\[C=white\]!\\Z7!gmi; $text =~ s!\[B\]!\\Zb!gmi; $text =~ s!\[/B\]!\\ZB!gmi; $text =~ s!\[U\]!\\Zu!gmi; $text =~ s!\[/U\]!\\ZU!gmi; $text =~ s!\[R\]!\\Zr!gmi; $text =~ s!\[/R\]!\\ZR!gmi; $text =~ s!\[N\]!\\Zn!gmi; $text =~ s!\[A=\w+\]!!gmi; return($text); } else { return($self->_strip_text($text)); } } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: test for the good stuff sub is_cdialog { my $self = $_[0]; return(1) if $self->{'_variant'} && $self->{'_variant'} eq "cdialog"; return(0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Ask a binary question (Yes/No) sub yesno { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--yesno {{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $self->rv($rv); } else { $self->ra("YES"); $self->rs("YES"); $self->rv('null'); } $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text entry sub inputbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); if ($args->{'password'}) { if ($args->{'entry'}) { $fmt = $self->append_format($fmt,'--insecure'); } else { $fmt = $self->append_format_check($args,$fmt,'insecure','--insecure'); } $fmt = $self->append_format($fmt,'--passwordbox'); } else { $fmt = $self->append_format($fmt,'--inputbox'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{entry}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), entry => $self->make_kvl($args,($args->{'init'}||$args->{'entry'})), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $text : 0); } #: password boxes aren't supported by gdialog sub password { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'password',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text box sub msgbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'msgbox'} ||= 'msgbox'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); if ($args->{'infobox'}) { $fmt = $self->append_format($fmt,'--infobox'); } else { $fmt = $self->append_format($fmt,'--msgbox'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); if ($args->{'infobox'}) { my $sec = 0; if ($args->{'timeout'}) { $sec = int($args->{'timeout'} ? ($args->{'timeout'} / 1000.0) : 1.0); $self->_debug("Will sleep for timeout=".$sec); } elsif ($args->{'wait'}) { $sec = int($args->{'wait'} ? $args->{'wait'} : 1); $self->_debug("Will sleep for wait=".$sec); } sleep($sec) if $sec; } $self->_post($args); return($rv == 0 ? 1 : 0); } sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'infobox',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: File box sub textbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--scrolltext'); $fmt = $self->append_format($fmt,'--textbox'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'path'}||'.')), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a simple menu sub menu { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} = $args->{'menuheight'} if exists $args->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--menu'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a check list sub checklist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} = $args->{'menuheight'} if exists $args->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $args->{radiolist} ||= 0; if ($args->{radiolist}) { $fmt = $self->append_format($fmt,'--radiolist'); } else { $fmt = $self->append_format($fmt,'--separate-output'); $fmt = $self->append_format($fmt,'--checklist'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); if ($args->{radiolist}) { my ($rv,$selected) = $self->command_string($command); return($rv == 0 ? $selected : 0); } my ($rv,$selected) = $self->command_array($command); return($rv == 0 ? @{$selected} : 0); } #: a radio button list sub radiolist { my $self = shift(); return($self->checklist('caller',((caller(1))[3]||'main'),@_,'radiolist',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: file select sub fselect { my $self = shift(); unless ($self->is_cdialog()) { return($self->SUPER::fselect(@_)); } my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--fselect'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'path'}||'.')), ); my ($rv,$file) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $file : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: calendar sub calendar { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'day'} ||= '1'; $args->{'month'} ||= '1'; $args->{'year'} ||= '1970'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--calendar {{text}} {{listheight}} {{width}} {{day}} {{month}} {{year}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$date) = $self->command_string($command); if ($rv == 0) { $self->ra(split(m!/!,$date)); } $self->_post($args); return($rv == 0 ? $date : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0,0,0)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: timebox sub timebox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); $args->{'hour'} ||= $hour; $args->{'minute'} ||= $min; $args->{'second'} ||= $sec; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--timebox {{text}} {{height}} {{width}} {{hour}} {{minute}} {{second}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$time) = $self->command_string($command); if ($rv == 0) { $self->ra(split(m!\:!,$time)); } $self->_post($args); return($rv == 0 ? $time : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0,0,0)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: tailbox sub tailbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--tailbox'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'path'}||'.')), ); my ($rv) = $self->command_state($command); $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: tailboxbg sub tailboxbg { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--tailboxbg'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'path'}||'.')), ); my ($rv) = $self->command_state($command); $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: an editable form (wow is this useful! holy cripes!) sub form { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} = $args->{'menuheight'} if exists $args->{'menuheight'}; $args->{'listheight'} = $args->{'formheight'} if exists $args->{'formheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--form'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $list = ''; while (@{$args->{'list'}}) { my $item = shift(@{$args->{'list'}}); my $info = shift(@{$args->{'list'}}); $self->clean_format($args->{'trust-input'},\$item->[0]); $self->clean_format($args->{'trust-input'},\$item->[1]); $self->clean_format($args->{'trust-input'},\$item->[2]); $self->clean_format($args->{'trust-input'},\$info->[0]); $self->clean_format($args->{'trust-input'},\$info->[1]); $self->clean_format($args->{'trust-input'},\$info->[2]); $self->clean_format($args->{'trust-input'},\$info->[3]); $self->clean_format($args->{'trust-input'},\$info->[4]); $list .= ' "'.($item->[0]||' ').'" "'.$item->[1].'" "'.$item->[2].'" "'.($info->[0]||' ').'" "'.$info->[1].'" "'.$info->[2].'" "'.$info->[3].'" "'.$info->[4].'"'; } delete $args->{'list'}; $args->{'list'} = $list; my $command = $self->prepare_command ( $args, $fmt, list => $self->make_kvl($args,$args->{'list'}), ); my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: progress meter sub gauge_start { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'_GAUGE'} ||= {}; $self->{'_GAUGE'}->{'ARGS'} = $args; if (defined $self->{'_GAUGE'}->{'FH'}) { $self->rv(129); $self->_post($args); return(0); } my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--gauge'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{percentage}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), percentage => $self->make_kvl($args,$args->{'percentage'}||'0'), ); $self->{'_GAUGE'}->{'PERCENT'} = ($args->{'percentage'} || '0'); $self->{'_GAUGE'}->{'FH'} = new FileHandle; $self->{'_GAUGE'}->{'FH'}->open("| $command"); my $rv = $? >> 8; $self->{'_GAUGE'}->{'FH'}->autoflush(1); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); return($rv && $rv >= 1); } sub gauge_inc { my $self = $_[0]; my $incr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} += $incr; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_dec { my $self = $_[0]; my $decr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} -= $decr; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_set { my $self = $_[0]; my $perc = $_[1] || $self->{'_GAUGE'}->{'PERCENT'} || 1; return(0) unless $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} = $perc; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } # funky flicker... grr sub gauge_text { my $self = $_[0]; my $mesg = $_[1] || return(0); return(0) unless $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh "\nXXX\n\n".$mesg."\n\nXXX\n\n".$self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_stop { my $self = $_[0]; return(0) unless $self->{'_GAUGE'}->{'FH'}; my $args = $self->{'_GAUGE'}->{'ARGS'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; $self->{'_GAUGE'}->{'FH'}->close(); delete($self->{'_GAUGE'}->{'FH'}); delete($self->{'_GAUGE'}->{'ARGS'}); delete($self->{'_GAUGE'}->{'PERCENT'}); delete($self->{'_GAUGE'}); $self->rv('null'); $self->rs('null'); $self->ra('null'); $self->_post($args); return(1); } 1; PK ! ��.v v Dialog/Backend/XOSD.podnu ��6�$ =head1 NAME UI::Dialog::Backend::XOSD - backend for the osd_cat(1). =head1 SYNOPSIS use UI::Dialog::Backend::XOSD; my $xosd = new UI::Dialog::Backend::XOSD (); $xosd->line( text => "Something to display..."); =head1 ABSTRACT UI::Dialog::Backend::XOSD is an OOPerl wrapper for the osd_cat(1) program. =head1 DESCRIPTION Use this module to present feedback to the end user via an on-screen display (like an on-screen TV volume meter). When you use any of the UI::Dialog meta classes (UI::Dialog, UI::Dialog::GNOME, etc.) access to this backend is provided via the $d->xosd method. ie: replace $xosd with $d->xosd in the synopsis example (provided you made $d with something like my $d = new UI::Dialog...). Also, UI::Dialog (and friends) only load this module when you first use the $d->xosd method (this may silently fail, but you can test by ref() for success). =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $xosd = new UI::Dialog::Backend::XOSD ( ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. All methods accept the same arguments as new() except that the arguments passed to the methods are temporarily used instead of making them the default as the new() method does. In the case of the 'wait' option, any (non-zero) value enables the option as it's a switch and not a string argument. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::XOSD class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<offset = \d+> (0) * =item B<align = \w+> ('left') * =item B<indent = \d+> (0) * =item B<font = "x-font-string"> ('fixed') * =item B<colour = \w+> ('red') * =item B<delay = \d+> (5) * =item B<lines = \d+> (5) * =item B<shadow = \d+> (0) * =item B<age = \d+> (0) * =item B<wait = 0,1> (0) * =back =back =head1 METHODS =head2 line( ) =over 4 =item EXAMPLE =over 6 $xosd->line( text => "some text to display" ); =back =item DESCRIPTION =over 6 Display a simple string on the screen. =back =item RETURNS =over 6 Nothing. =back =back =head2 file( ) =over 4 =item EXAMPLE =over 6 $xosd->file( file => "/path/to/a/file" ); =back =item DESCRIPTION =over 6 Display a file on the screen. =back =item RETURNS =over 6 Nothing. =back =back =head2 gauge( ) =over 4 =item EXAMPLE =over 6 $xosd->gauge( text => "", percent => $current_percentage, length => 40, bar => "-", mark => "|" ); =back =item DESCRIPTION =over 6 Display a gauge bar with a percentage mark on the screen with an optional message. =back =item RETURNS =over 6 Nothing. =back =back =head2 display_start( ) =over 4 =item EXAMPLE =over 6 $xosd->display_start( ); =back =item DESCRIPTION =over 6 Opens a pipe command to the osd_cat(1) program for prolonged interactivity. This accepts all of the standard options but has nothing else to offer. The other display_*() methods (detailed below) return zero unless this method has been used and has created the command pipe. =back =item RETURNS =over 6 TRUE (1) for success and FALSE (0) otherwise. =back =back =head2 display_text( ) =over 4 =item EXAMPLE =over 6 $xosd->display_start(); $xosd->display_text( "Some string to display." ); =back =item DESCRIPTION =over 6 Uses the command pipe created by display_start() and prints the first argument to the screen. This method does not have any options, save the one string scalar. =back =item RETURNS =over 6 TRUE (1) for success and FALSE (0) otherwise. =back =back =head2 display_gauge( ) =over 4 =item EXAMPLE =over 6 $xosd->display_start(); $xosd->display_gauge( 50, "display an optional text string." ); =back =item DESCRIPTION =over 6 Uses the command pipe created by display_start() and prints a gauge identical to the regular (stand-alone) gauge() method. There are only to accepted arguments; the desired percentage and an optional text string. =back =item RETURNS =over 6 TRUE (1) for success and FALSE (0) otherwise. =back =back =head2 display_stop( ) =over 4 =item EXAMPLE =over 6 $xosd->display_start(); $xosd->display_text( "about to stop!" ); $xosd->display_stop(); =back =item DESCRIPTION =over 6 This closes the command pipe opened by the display_start() method. This method takes no arguments and performs only the task for closing and existing command pipe. =back =item RETURNS =over 6 TRUE (1) for success and FALSE (0) otherwise. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Backend =back =over 2 =item MAN FILES osd_cat(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! q� � � Dialog/Backend/Nautilus.podnu ��6�$ =head1 NAME UI::Dialog::Backend::Nautilus - wrapper around the data provided by the nautilus(1). =head1 SYNOPSIS use UI::Dialog::Backend::Nautilus; my $nautilus = new UI::Dialog::Backend::Nautilus (); my @paths = $nautilus->paths(); =head1 ABSTRACT UI::Dialog::Backend::Nautilus is simply an OOPerl wrapper around the data provided by the nautilus(1) file manager's scripts feature. =head1 DESCRIPTION nautilus(1) is a GNOME file manager that has a "right-click" menu for user made scripts (found in the user's ~/.gnome2/nautilus-scripts/ directory). This is an OOPerl interface to the environment variables provided to the scripts during runtime by nautilus. When you use any of the UI::Dialog meta classes (UI::Dialog, UI::Dialog::GNOME, etc.) access to this backend is provided via the $d->nautilus method. ie: replace $nautilus with $d->nautilus in the synopsis example (provided you made $d with something like my $d = new UI::Dialog...). Also, UI::Dialog and friends only load this module when you first use the $d->nautilus method (this may silently fail, but you can test by ref() for success). =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 None =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $nautilus = new UI::Dialog::Backend::Nautilus (); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::Nautilus class. =back =back =head1 METHODS =head2 path( ) =over 4 =item EXAMPLE =over 6 my $path = $nautilus->path(); =back =item DESCRIPTION =over 6 This method examines the NAUTILUS_SCRIPT_CURRENT_URI string uri unescapes and strips it of any prefixing protocol indicators (file://) then returns the modified string. =back =item RETURNS =over 6 a SCALAR. =back =back =head2 paths( ) =over 4 =item EXAMPLE =over 6 my @paths = $nautilus->paths(); =back =item DESCRIPTION =over 6 This method splits the NAUTILUS_SCRIPT_SELECTED_FILE_PATHS multiline string and returns the ARRAY of selections in the order provided by nautilus. =back =item RETURNS =over 6 an ARRAY. =back =back =head2 uri( ) =over 4 =item EXAMPLE =over 6 my $uri = $nautilus->uri(); =back =item DESCRIPTION =over 6 This simply returns the NAUTILUS_SCRIPT_CURRENT_URI string. =back =item RETURNS =over 6 a SCALAR. =back =back =head2 uris( ) =over 4 =item EXAMPLE =over 6 my @uris = $nautilus->uris(); =back =item DESCRIPTION =over 6 This method splits the NAUTILUS_SCRIPT_SELECTED_URIS multiline string and returns the ARRAY of selections in the order provided by nautilus. This does not uri escape or unescape the string. =back =item RETURNS =over 6 an ARRAY. =back =back =head2 geometry( ) =over 4 =item EXAMPLE =over 6 my ($h,$w,$x,$y) = $nautilus->geometry(); =back =item DESCRIPTION =over 6 This method splits the NAUTILUS_SCRIPT_WINDOW_GEOMETRY string and returns and ARRAY of the geometry details provided by nautilus. The array returned contains the following (in order): height width X-coordinate Y-coordinate =back =item RETURNS =over 6 an ARRAY. =back =back =head2 uri_unescape( ) =over 4 =item EXAMPLE =over 6 my $path = $nautilus->uri_unescape( "file:///path/to/somewhere" ); my @paths = $nautilus->uri_unescape( "file:///path/to/somewhere", "file:///yet/another/path" ); =back =item DESCRIPTION =over 6 This is the method used to unescape the NAUTILUS_SCRIPT_CURRENT_URI in the path() method. This method is derived from the URI::Escape module which is not included in the Perl core modules yet is vitally necessary for the path() method to function in a useful manor. =back =item RETURNS =over 6 an ARRAY or a SCALAR depending on the calling arguments. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Backend =back =over 2 =item MAN FILES nautilus(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! g�o�Q �Q Dialog/Backend/Zenity.pmnu ��6�$ package UI::Dialog::Backend::Zenity; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use FileHandle; use Cwd qw( abs_path ); use UI::Dialog::Backend; use File::Slurp; use String::ShellQuote; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_state'} = {}; $self->{'_opts'} = {}; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'literal'} = $cfg->{'literal'} || 0; $self->{'_opts'}->{'debug'} = $cfg->{'debug'} || undef(); $self->{'_opts'}->{'window-icon'} = $cfg->{'window-icon'} || undef(); $self->{'_opts'}->{'title'} = $cfg->{'title'} || undef(); $self->{'_opts'}->{'width'} = $cfg->{'width'} || 65; $self->{'_opts'}->{'height'} = $cfg->{'height'} || 10; $self->{'_opts'}->{'display'} = $cfg->{'display'} || undef(); $self->{'_opts'}->{'name'} = $cfg->{'name'} || undef(); $self->{'_opts'}->{'class'} = $cfg->{'class'} || undef(); $self->{'_opts'}->{'bin'} = $self->_find_bin('zenity'); $self->{'_opts'}->{'autoclear'} = $cfg->{'autoclear'} || 0; $self->{'_opts'}->{'clearbefore'} = $cfg->{'clearbefore'} || 0; $self->{'_opts'}->{'clearafter'} = $cfg->{'clearafter'} || 0; $self->{'_opts'}->{'beepbin'} = $cfg->{'beepbin'} || $self->_find_bin('beep') || '/usr/bin/beep'; $self->{'_opts'}->{'beepbefore'} = $cfg->{'beepbefore'} || 0; $self->{'_opts'}->{'beepafter'} = $cfg->{'beepafter'} || 0; $self->{'_opts'}->{'callbacks'} = $cfg->{'callbacks'} || undef(); $self->{'_opts'}->{'timeout'} = $cfg->{'timeout'} || 0; $self->{'_opts'}->{'wait'} = $cfg->{'wait'} || 0; unless (-x $self->{'_opts'}->{'bin'}) { croak("the zenity binary could not be found at: ".$self->{'_opts'}->{'bin'}); } $self->{'_opts'}->{'trust-input'} = $cfg->{'trust-input'} || 0; my $command = $self->{'_opts'}->{'bin'}." --version"; my $version = `$command 2>&1`; chomp( $version ); $self->{'ZENITY_VERSION'} = $version || '1'; $self->{'test_mode'} = $cfg->{'test_mode'} if exists $cfg->{'test_mode'}; $self->{'test_mode_result'} = ''; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: my $SIG_CODE = {}; sub _del_gauge { #: this is beyond self... my $CODE = $SIG_CODE->{$$}; unless (not ref($CODE)) { delete($CODE->{'_GAUGE'}); $CODE->rv('1'); $CODE->rs('null'); $CODE->ra('null'); $SIG_CODE->{$$} = ""; } } sub append_format_base { my ($self,$args,$fmt) = @_; $ENV{'ZENITY_CANCEL'} = '1'; $ENV{'ZENITY_ERROR'} = '254'; $ENV{'ZENITY_ESC'} = '255'; $ENV{'ZENITY_EXTRA'} = '3'; $ENV{'ZENITY_HELP'} = '2'; $ENV{'ZENITY_OK'} = '0'; $fmt = $self->append_format_check($args,$fmt,'window-icon','--window-icon {{window-icon}}'); $fmt = $self->append_format_check($args,$fmt,'width','--width {{width}}'); $fmt = $self->append_format_check($args,$fmt,'height','--height {{height}}'); $fmt = $self->append_format_check($args,$fmt,'display','--display {{display}}'); $fmt = $self->append_format_check($args,$fmt,'name','--name {{name}}'); $fmt = $self->append_format_check($args,$fmt,'class','--class {{class}}'); return $fmt; } sub _is_bad_version { # my $self = shift(); # my ($d_maj, $d_min, $d_mac) = ( 1, 4, 0 ); # my ($z_maj, $z_min, $z_mac) = ( 0, 0, 0 ); # my $zenity_version = $self->{'ZENITY_VERSION'} || '0.0.0'; # if ( $zenity_version =~ m!^(\d+)\.(\d+)\.(\d+)$! ) { # ($z_maj, $z_min, $z_mac) = ( $1, $2, $3 ); # } # if ( ( $d_maj < $z_maj ) || # ( $d_maj == $z_maj && $d_min < $z_min ) || # ( $d_maj == $z_maj && $d_min == $z_min && $d_mac < $z_mac ) # ) { # return(0); # } return(1); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Override Inherited Methods #: # May want to override Backend::perform_command(). Not sure. #: run command and return the rv and any text output from stderr sub perform_command { my $self = $_[0]; my $cmnd = $_[1]; if ($self->is_unit_test_mode()) { $self->{'test_mode_result'} = $cmnd; return (0,'test_mode_result'); } $self->_debug("perform_command: ".$cmnd.";"); my $null_dev = $^O =~ /win32/i ? 'NUL:' : '/dev/null'; my $tmp_stderr = $self->gen_tempfile_name(); system($cmnd." 2> $null_dev > ".$tmp_stderr); my $rv = $? >> 8; my $text = read_file($tmp_stderr); unlink($tmp_stderr) if -f $tmp_stderr; $self->_debug("perform_command: stderr=".shell_quote($text),2); return ($rv,$text); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Ask a binary question (Yes/No) sub question { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--question --text {{text}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); } else { $self->ra("YES"); $self->rs("YES"); } $self->_post($args); return($rv == 0 ? 1 : 0); } #: Zenity doesn't support alternation of the buttons like gdialog et al. #: so here we just wrap for compliance. sub yesno { my $self = shift(); return($self->question('caller',((caller(1))[3]||'main'),@_)); } sub noyes { my $self = shift(); return($self->question('caller',((caller(1))[3]||'main'),@_)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text entry sub entry { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'entry'} ||= ($args->{'init'} || $args->{'entry'}); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--entry'); $fmt = $self->append_format_check($args,$fmt,'hide-text','--hide-text'); $fmt = $self->append_format_check($args,$fmt,'entry','--entry-text {{entry}}'); $fmt = $self->append_format($fmt,'--text {{text}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $text : 0); } sub inputbox { my $self = shift(); return($self->entry('caller',((caller(1))[3]||'main'),@_)); } sub password { my $self = shift(); return($self->entry('caller',((caller(1))[3]||'main'),@_,'hide-text',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text box sub info { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); if ($args->{'error'}) { $fmt = $self->append_format($fmt,'--error'); } elsif ($args->{'warning'}) { $fmt = $self->append_format($fmt,'--warning'); } else { $fmt = $self->append_format($fmt,'--info'); } $fmt = $self->append_format($fmt,'--text {{text}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); $self->_post($args); return($rv == 0 ? 1 : 0); } sub infobox { my $self = shift(); return($self->info('caller',((caller(1))[3]||'main'),@_)); } sub msgbox { my $self = shift(); return($self->info('caller',((caller(1))[3]||'main'),@_)); } sub error { my $self = shift(); return($self->info('caller',((caller(1))[3]||'main'),@_,'error',1)); } sub warning { my $self = shift(); return($self->info('caller',((caller(1))[3]||'main'),@_,'warning',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: File box sub text_info { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $filename = $args->{'path'} || $args->{'filename'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--text-info'); $fmt = $self->append_format_check($args,$fmt,'editable','--editable'); $fmt = $self->append_format($fmt,'--filename {{filename}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), filename => $self->make_kvl($args,$filename) ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $text : 0); } sub textbox { my $self = shift(); return($self->text_info('caller',((caller(1))[3]||'main'),@_)); } sub editbox { my $self = shift(); return($self->text_info('caller',((caller(1))[3]||'main'),@_,'editable',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Lists sub list { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--list'); $args->{'checklist'} ||= 0; $args->{'radiolist'} ||= 0; if ($args->{'checklist'}) { $fmt = $self->append_format($fmt,'--checklist'); } elsif ($args->{'radiolist'}) { $fmt = $self->append_format($fmt,'--radiolist'); } $fmt = $self->append_format($fmt,"--separator '\\n'"); if (ref($args->{'list'}) eq "ARRAY") { if ($args->{'checklist'}||$args->{'radiolist'}) { $fmt = $self->append_format($fmt,'--column " " --column " " --column " "'); } else { $fmt = $self->append_format($fmt,'--column " " --column " "'); } while (@{$args->{'list'}}) { my $item = shift(@{$args->{'list'}}); $self->clean_format($args->{'trust-input'},\$item); my $info = shift(@{$args->{'list'}}); if (ref($info) eq "ARRAY") { $self->clean_format($args->{'trust-input'},\$info->[0]); $fmt = $self->append_format($fmt,'"'.(($info->[1]) ? 'TRUE' : 'FALSE').'"'); $fmt = $self->append_format($fmt,'"'.$item.'"'); $fmt = $self->append_format($fmt,'"'.$info->[0].'"'); } else { $self->clean_format($args->{'trust-input'},\$info); $fmt = $self->append_format($fmt,'"'.$item.'"'); $fmt = $self->append_format($fmt,'"'.$info.'"'); } } } else { croak("Programmer error. list argument missing or not an array.") } my $command = $self->prepare_command( $args, $fmt ); if ($args->{'checklist'}) { my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } sub menu { my $self = shift(); return($self->list('caller',((caller(1))[3]||'main'),@_)); } sub checklist { my $self = shift(); return($self->list('caller',((caller(1))[3]||'main'),@_,'checklist',1)); } sub radiolist { my $self = shift(); return($self->list('caller',((caller(1))[3]||'main'),@_,'radiolist',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: file select sub fselect { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $filename = $args->{'path'} || $args->{'filename'} || abs_path(); $args->{'path'} = $filename; $args->{'path'} = (-d $args->{'path'}) ? $args->{'path'}."/" : $args->{'path'}; $args->{'path'} =~ s!/+!/!g; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--file-selection'); $fmt = $self->append_format($fmt,'--filename {{filename}}'); my $command = $self->prepare_command ( $args, $fmt, filename => $self->make_kvl($args,$filename) ); $self->_debug("fselect: ".$args->{'path'}); my ($rv,$file) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $file : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: directory select sub dselect { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $filename = $args->{'path'} || $args->{'filename'} || abs_path(); $args->{'path'} = $filename; $args->{'path'} = (-d $args->{'path'}) ? $args->{'path'}."/" : $args->{'path'}; $args->{'path'} =~ s!/+!/!g; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--file-selection --directory'); $fmt = $self->append_format($fmt,'--filename {{filename}}'); my $command = $self->prepare_command ( $args, $fmt, filename => $self->make_kvl($args,$filename) ); $self->_debug("fselect: ".$args->{'path'}); my ($rv,$file) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $file : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: calendar sub calendar { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--calendar'); $fmt = $self->append_format_check($args,$fmt,'text','--text {{text}}'); $fmt = $self->append_format_check($args,$fmt,'date-format','--date-format {{date-format}}'); $fmt = $self->append_format_check($args,$fmt,'day','--day {{day}}'); $fmt = $self->append_format_check($args,$fmt,'month','--month {{month}}'); $fmt = $self->append_format_check($args,$fmt,'year','--year {{year}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$date) = $self->command_string($command); if ($rv == 0) { $self->ra(split(m!/!,$date)); } $self->_post($args); return($rv == 0 ? $date : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0,0,0)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: progress sub gauge_start { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'_GAUGE'} ||= {}; $self->{'_GAUGE'}->{'ARGS'} = $args; if (defined $self->{'_GAUGE'}->{'FH'}) { $self->rv(129); $self->_post($args); return(0); } my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--progress'); $fmt = $self->append_format_check($args,$fmt,'pulsate','--pulsate'); $fmt = $self->append_format_check($args,$fmt,'text','--text {{text}}'); $fmt = $self->append_format($fmt,'--percentage {{percentage}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), percentage => $self->make_kvl($args,$args->{'percentage'}||'0'), ); $self->{'_GAUGE'}->{'PERCENT'} = ($args->{'percentage'} || '0'); $self->{'_GAUGE'}->{'FH'} = new FileHandle; $self->{'_GAUGE'}->{'FH'}->open("| $command"); my $rv = ($? >> 8); $self->{'_GAUGE'}->{'FH'}->autoflush(1); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); return($rv == 0 ? 1 : 0); } sub gauge_inc { my $self = $_[0]; my $incr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} += $incr; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_dec { my $self = $_[0]; my $decr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} -= $decr; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_set { my $self = $_[0]; my $perc = $_[1] || $self->{'_GAUGE'}->{'PERCENT'} || 1; return(0) unless $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} = $perc; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } #: Textual updates are not supported by Zenity... sub gauge_text { my $self = $_[0]; my $mesg = $_[1] || return(0); my $fh = $self->{'_GAUGE'}; return(0) unless $self->{'_GAUGE'}; # $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; # print $fh "\nXXX\n\n".$mesg."\n\nXXX\n\n".$self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}) ? 1 : 0)); } sub gauge_stop { my $self = $_[0]; my $args = $self->{'_GUAGE'}->{'ARGS'} || $self->_merge_attrs( title => 'gauge_stop', 'caller' => ((caller(1))[3]||'main') ); unless ($self->{'_GAUGE'}->{'FH'}) { $self->rv(129); $self->_post($args); return(0); } my $fh = $self->{'_GAUGE'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; $self->{'_GAUGE'}->{'FH'}->close(); delete($self->{'_GAUGE'}->{'ARGS'}); delete($self->{'_GAUGE'}->{'FH'}); delete($self->{'_GAUGE'}->{'PERCENT'}); delete($self->{'_GAUGE'}); $self->rv('null'); $self->rs('null'); $self->ra('null'); $self->_post($args); return(1); } 1; PK ! SL�T�� �� Dialog/Backend/XDialog.pmnu ��6�$ package UI::Dialog::Backend::XDialog; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use FileHandle; use File::Basename; use Cwd qw( abs_path ); use String::ShellQuote; use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_state'} = {}; $self->{'_opts'} = {}; $self->{'test_mode'} = ($cfg->{'test_mode'}) ? 1 : 0; $self->{'test_mode_result'} = ''; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'debug'} = $cfg->{'debug'} || undef(); $self->{'_opts'}->{'literal'} = $cfg->{'literal'} || 0; $self->{'_opts'}->{'XDIALOG_HIGH_DIALOG_COMPAT'} = 1 unless not $cfg->{'XDIALOG_HIGH_DIALOG_COMPAT'}; $self->{'_opts'}->{'callbacks'} = $cfg->{'callbacks'} || undef(); # --wmclass <name> $self->{'_opts'}->{'wmclass'} = $cfg->{'wmclass'} || undef(); # --rc-file <gtkrc filename> $self->{'_opts'}->{'rcfile'} = $cfg->{'rcfile'} || undef(); # --backtitle <backtitle> $self->{'_opts'}->{'backtitle'} = $cfg->{'backtitle'} || undef(); # --title <title> $self->{'_opts'}->{'title'} = $cfg->{'title'} || undef(); # --allow-close | --no-close $self->{'_opts'}->{'allowclose'} = $cfg->{'allowclose'} || 0; $self->{'_opts'}->{'noclose'} = $cfg->{'noclose'} || 0; # --screen-center | --under-mouse | --auto-placement $self->{'_opts'}->{'screencenter'} = $cfg->{'screencenter'} || 0; $self->{'_opts'}->{'undermouse'} = $cfg->{'undermouse'} || 0; $self->{'_opts'}->{'autoplacement'} = $cfg->{'autoplacement'} || 0; # --center | --right | --left | --fill $self->{'_opts'}->{'center'} = $cfg->{'center'} || 0; $self->{'_opts'}->{'right'} = $cfg->{'right'} || 0; $self->{'_opts'}->{'left'} = $cfg->{'left'} || 0; $self->{'_opts'}->{'fill'} = $cfg->{'fill'} || 0; # --no-wrap | --wrap $self->{'_opts'}->{'nowrap'} = $cfg->{'nowrap'} || 0; $self->{'_opts'}->{'wrap'} = $cfg->{'wrap'} || 0; # --cr-wrap | --no-cr-wrap $self->{'_opts'}->{'crwrap'} = $cfg->{'crwrap'} || 0; $self->{'_opts'}->{'nocrwrap'} = $cfg->{'nocrwrap'} || 0; # --buttons-style default|icon|text $self->{'_opts'}->{'buttonsstyle'} = $cfg->{'buttonsstyle'} || 'default'; # --fixed-font (tailbox, textbox, and editbox) $self->{'_opts'}->{'fixedfont'} = $cfg->{'fixedfont'} || 0; # --editable (combobox) $self->{'_opts'}->{'editable'} = $cfg->{'editable'} || 0; # --time-stamp | --date-stamp (logbox) $self->{'_opts'}->{'timestamp'} = $cfg->{'timestamp'} || 0; $self->{'_opts'}->{'datestamp'} = $cfg->{'datestamp'} || 0; # --reverse (logbox) $self->{'_opts'}->{'reverse'} = $cfg->{'reverse'} || 0; # --keep-colors (logbox) $self->{'_opts'}->{'keepcolors'} = $cfg->{'keepcolours'} || $cfg->{'keepcolors'} || 0; # --interval <timeout> (input(s) boxes, combo box, range(s) boxes, spin(s) boxes, list boxes, menu box, treeview, calendar, timebox) $self->{'_opts'}->{'interval'} = $cfg->{'interval'} || 0; # --no-tags (menubox, checklist and radiolist) $self->{'_opts'}->{'notags'} = $cfg->{'notags'} || 0; # --item-help (menubox, checklist, radiolist, buildlist and treeview) $self->{'_opts'}->{'itemhelp'} = $cfg->{'itemhelp'} || 0; # --default-item <tag> (menubox) $self->{'_opts'}->{'defaultitem'} = $cfg->{'defaultitem'} || undef(); # --icon <xpm filename> (textbox, editbox, tailbox, logbox, fselect and dselect) $self->{'_opts'}->{'icon'} = $cfg->{'icon'} || undef(); # --no-ok (tailbox and logbox) $self->{'_opts'}->{'nook'} = $cfg->{'nook'} || 0; # --no-cancel (infobox, gauge and progress) $self->{'_opts'}->{'nocancel'} = $cfg->{'nocancel'} || 0; # --no-buttons (textbox, tailbox, logbox, infobox fselect and dselect) $self->{'_opts'}->{'nobuttons'} = $cfg->{'nobuttons'} || 0; # --default-no !(wizard) $self->{'_opts'}->{'defaultno'} = $cfg->{'defaultno'} || 0; # --wizard !(msgbox, infobox, gauge and progress) $self->{'_opts'}->{'wizard'} = $cfg->{'wizard'} || 0; # --help <help> (infobox, gauge and progress) $self->{'_opts'}->{'help'} = $cfg->{'help'} || undef(); # --print <printer> (textbox, editbox and tailbox) $self->{'_opts'}->{'print'} = $cfg->{'print'} || undef(); # --check <label> !(infobox, gauge and progress) $self->{'_opts'}->{'check'} = $cfg->{'check'} || undef(); # --ok-label <label> !(wizard) $self->{'_opts'}->{'oklabel'} = $cfg->{'oklabel'} || undef(); # --cancel-label <label> !(wizard) $self->{'_opts'}->{'cancellabel'} = $cfg->{'cancellabel'} || undef(); # --beep | --beep-after (all) $self->{'_opts'}->{'beepbin'} = $cfg->{'beepbin'} || $self->_find_bin('beep') || '/usr/bin/beep'; $self->{'_opts'}->{'beepbefore'} = $cfg->{'beepbefore'} || 0; $self->{'_opts'}->{'beepafter'} = $cfg->{'beepafter'} || 0; # --begin <Yorg> <Xorg> (all) $self->{'_opts'}->{'begin'} = $cfg->{'begin'} || undef(); #: 'begin' => [$y,$x] # --ignore-eof (infobox and gauge) $self->{'_opts'}->{'ignoreeof'} = $cfg->{'ignoreeof'} || 0; # --smooth (tailbox and logbox) $self->{'_opts'}->{'smooth'} = $cfg->{'smooth'} || 0; #: \/we handle these internally\/ # --stderr | --stdout # --separator <character> | --separate-output #: ^^we handle these internally^^ $self->{'_opts'}->{'bin'} ||= $self->_find_bin('Xdialog'); unless (-x $self->{'_opts'}->{'bin'}) { croak("the Xdialog binary could not be found."); } #: to determin upper limits use: # --print-maxsize #: STDOUT| MaxSize: \d+(width), \d+(height) my $command = $self->{'_opts'}->{'bin'}." --print-maxsize"; my $raw = `$command 2>&1`; my ($w,$h) = (0,0); if ($raw =~ m!^\s*MaxSize\:\s+(\d+?),\s+(\d+?)\s*$!) { ($w,$h) = ($1,$2); } $self->{'_opts'}->{'width'} = $cfg->{'width'} || $w; $self->{'_opts'}->{'height'} = $cfg->{'height'} || $h; $self->{'_opts'}->{'listheight'} = $cfg->{'listheight'} || $cfg->{'menuheight'} || 5; $self->{'_opts'}->{'percentage'} = $cfg->{'percentage'} || 1; $self->{'_opts'}->{'autoclear'} = $cfg->{'autoclear'} || 0; $self->{'_opts'}->{'clearbefore'} = $cfg->{'clearbefore'} || 0; $self->{'_opts'}->{'clearafter'} = $cfg->{'clearafter'} || 0; $self->{'_opts'}->{'timeout'} = $cfg->{'timeout'} || 0; $self->{'_opts'}->{'wait'} = $cfg->{'wait'} || 0; $self->{'_opts'}->{'trust-input'} = $cfg->{'trust-input'} || 0; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: my $SIG_CODE = {'PROGRESS'=>{},'GAUGE'=>{}}; sub _del_progress { my $CODE = $SIG_CODE->{'PROGRESS'}->{$$}; unless (not ref($CODE)) { delete($CODE->{'_PROGRESS'}); $CODE->rv('1'); $CODE->rs('null'); $CODE->ra('null'); $SIG_CODE->{$$} = ""; } } sub _del_gauge { my $CODE = $SIG_CODE->{'GAUGE'}->{$$}; unless (not ref($CODE)) { delete($CODE->{'_GAUGE'}); $CODE->rv('1'); $CODE->rs('null'); $CODE->ra('null'); $SIG_CODE->{$$} = ""; } } sub append_format_base { my ($self,$args,$fmt) = @_; $fmt = 'XDIALOG_HIGH_DIALOG_COMPAT="1" ' . $fmt if $args->{'XDIALOG_HIGH_DIALOG_COMPAT'}; $fmt = $self->append_format_check($args,$fmt,"editable","--editable"); $fmt = $self->append_format_check($args,$fmt,"center","--center"); $fmt = $self->append_format_check($args,$fmt,"right","--right"); $fmt = $self->append_format_check($args,$fmt,"left","--left"); $fmt = $self->append_format_check($args,$fmt,"fill","--fill"); $fmt = $self->append_format_check($args,$fmt,"wrap","--wrap"); $fmt = $self->append_format_check($args,$fmt,"crwrap","--crwrap"); $fmt = $self->append_format_check($args,$fmt,"nocrwrap","--nocrwrap"); $fmt = $self->append_format_check($args,$fmt,"reverse","--reverse"); $fmt = $self->append_format_check($args,$fmt,"wizard","--wizard"); $fmt = $self->append_format_check($args,$fmt,"smooth","--smooth"); $fmt = $self->append_format_check($args,$fmt,'backtitle','--backtitle {{backtitle}}'); $args->{'no-wrap'} ||= $args->{'nowrap'} || 0; $fmt = $self->append_format_check($args,$fmt,"no-wrap","--no-wrap"); $args->{'allow-close'} ||= $args->{'allowclose'} || 0; $fmt = $self->append_format_check($args,$fmt,"allow-close","--allow-close"); $args->{'no-close'} ||= $args->{'noclose'} || 0; $fmt = $self->append_format_check($args,$fmt,"no-close","--no-close"); $args->{'screen-center'} ||= $args->{'screencenter'} || 0; $fmt = $self->append_format_check($args,$fmt,"screen-center","--screen-center"); $args->{'under-mouse'} ||= $args->{'undermouse'} || 0; $fmt = $self->append_format_check($args,$fmt,"under-mouse","--under-mouse"); $args->{'auto-placement'} ||= $args->{'autoplacement'} || 0; $fmt = $self->append_format_check($args,$fmt,"auto-placement","--auto-placement"); $args->{'fixed-font'} ||= $args->{'fixedfont'} || 0; $fmt = $self->append_format_check($args,$fmt,"fixed-font","--fixed-font"); $args->{'time-stamp'} ||= $args->{'timestamp'} || 0; $fmt = $self->append_format_check($args,$fmt,"time-stamp","--time-stamp"); $args->{'date-stamp'} ||= $args->{'datestamp'} || 0; $fmt = $self->append_format_check($args,$fmt,"date-stamp","--date-stamp"); $args->{'keep-colors'} ||= $args->{'keep-colours'} || $args->{'keepcolors'} || $args->{'keepcolours'}; $fmt = $self->append_format_check($args,$fmt,"keep-colors","--keep-colors"); $args->{'no-tags'} ||= $args->{'notags'} || 0; $fmt = $self->append_format_check($args,$fmt,"no-tags","--no-tags"); $args->{'item-help'} ||= $args->{'itemhelp'} || 0; $fmt = $self->append_format_check($args,$fmt,"item-help","--item-help"); $args->{'no-ok'} ||= $args->{'nook'} || 0; $fmt = $self->append_format_check($args,$fmt,"no-ok","--no-ok"); $args->{'no-cancel'} ||= $args->{'nocancel'} || 0; $fmt = $self->append_format_check($args,$fmt,"no-cancel","--no-cancel"); $args->{'no-buttons'} ||= $args->{'nobuttons'} || 0; $fmt = $self->append_format_check($args,$fmt,"no-buttons","--no-buttons"); $args->{'default-no'} ||= $args->{'defaultno'} || 0; $fmt = $self->append_format_check($args,$fmt,"default-no","--default-no"); $args->{'ignore-eof'} ||= $args->{'ignoreeof'} || 0; $fmt = $self->append_format_check($args,$fmt,"ignore-eof","--ignore-eof"); $fmt = $self->append_format_check($args,$fmt,"wmclass","--wmclass {{wmclass}}"); $fmt = $self->append_format_check($args,$fmt,"interval","--interval {{interval}}"); $fmt = $self->append_format_check($args,$fmt,"icon","--icon {{icon}}"); $fmt = $self->append_format_check($args,$fmt,"help","--help {{help}}"); $fmt = $self->append_format_check($args,$fmt,"print","--print {{print}}"); $fmt = $self->append_format_check($args,$fmt,"check",'--check {{check}}'); $args->{'rc-file'} ||= $args->{'rcfile'} || 0; $fmt = $self->append_format_check ( $args, $fmt, "rc-file", '--rc-file '.shell_quote($args->{'rc-file'}) ); $args->{'button-style'} ||= $args->{'buttonsstyle'} || 0; $fmt = $self->append_format_check ( $args, $fmt, "button-style", '--button-style '.shell_quote($args->{'button-style'}) ); $args->{'default-item'} ||= $args->{'defaultitem'} || 0; $fmt = $self->append_format_check ( $args, $fmt, "default-item", '--default-item '.shell_quote($args->{'default-item'}) ); $args->{'ok-label'} ||= $args->{'oklabel'} || 0; $fmt = $self->append_format_check ( $args, $fmt, "ok-label", '--ok-label '.shell_quote($args->{'ok-label'}) ); $args->{'cancel-label'} ||= $args->{'cancellabel'} || 0; $fmt = $self->append_format_check ( $args, $fmt, "cancel-label", '--cancel-label '.shell_quote($args->{'cancel-label'}) ); if (exists $args->{'begin'}) { my $begin = $args->{'begin'}; if (ref($begin) eq "ARRAY") { $fmt = $self->append_format($fmt,'--begin '.$begin->[0].' '.$begin->[1]); } } return $fmt; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: State Methods (override inherited) #: #: report on the state of the last widget. sub state { my $self = shift(); my $rv = $self->rv() || 0; $self->_debug((join(" | ",(caller())))." > state() > is: ".($rv||'NULL'),2); if ($rv == 1 or $rv == 129) { return("CANCEL"); } elsif ($rv == 2) { return("HELP"); } elsif ($rv == 3) { return("PREVIOUS"); } elsif ($rv == 254) { return("ERROR"); } elsif ($rv == 255) { return("ESC"); } elsif (not $rv or $rv =~ /^null$/i) { return("OK"); } else { return("UNKNOWN(".$rv.")"); } } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: # --combobox <text> <height> <width> <item1> ... <itemN> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a dropdown list that's editable sub combobox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --combobox {{text}} {{height}} {{width}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv ? $selected : 0); } # --rangebox <text> <height> <width> <min value> <max value> [<default value>] #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a slider bar with a preset range. sub rangebox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--rangebox {{text}} {{height}} {{width}} {{min}} {{max}} {{def}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), min => $self->make_kvl($args,($args->{'min'}||'0')), max => $self->make_kvl($args,($args->{'max'}||'100')), def => $self->make_kvl($args,($args->{'def'}||'0')), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv ? $selected : 0); } # --2rangesbox <text> <height> <width> <label1> <min1> <max1> <def1> <label2> <min2> <max2> <def2> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display two slider bars with preset ranges and labels sub rangesbox2 { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --2rangesbox {{text}} {{height}} {{width}}'); $fmt = $self->append_format($fmt,'{{label1}} {{min1}} {{max1}} {{def1}}'); $fmt = $self->append_format($fmt,'{{label2}} {{min2}} {{max2}} {{def2}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), label1 => $self->make_kvl($args,($args->{'label1'}||'')), min1 => $self->make_kvl($args,($args->{'min1'}||'0')), max1 => $self->make_kvl($args,($args->{'max1'}||'100')), def1 => $self->make_kvl($args,($args->{'def1'}||'0')), label2 => $self->make_kvl($args,($args->{'label2'}||'')), min2 => $self->make_kvl($args,($args->{'min2'}||'0')), max2 => $self->make_kvl($args,($args->{'max2'}||'100')), def2 => $self->make_kvl($args,($args->{'def2'}||'0')), ); my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } # --3rangesbox <text> <height> <width> <label1> <min1> <max1> <def1> <label2> <min2> <max2> <def2> <label3> <min3> <max3> <def3> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display three slider bars with preset ranges and labels sub rangesbox3 { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --3rangesbox {{text}} {{height}} {{width}}'); $fmt = $self->append_format($fmt,'{{label1}} {{min1}} {{max1}} {{def1}}'); $fmt = $self->append_format($fmt,'{{label2}} {{min2}} {{max2}} {{def2}}'); $fmt = $self->append_format($fmt,'{{label3}} {{min3}} {{max3}} {{def3}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), label1 => $self->make_kvl($args,($args->{'label1'}||'')), min1 => $self->make_kvl($args,($args->{'min1'}||'0')), max1 => $self->make_kvl($args,($args->{'max1'}||'100')), def1 => $self->make_kvl($args,($args->{'def1'}||'0')), label2 => $self->make_kvl($args,($args->{'label2'}||'')), min2 => $self->make_kvl($args,($args->{'min2'}||'0')), max2 => $self->make_kvl($args,($args->{'max2'}||'100')), def2 => $self->make_kvl($args,($args->{'def2'}||'0')), label3 => $self->make_kvl($args,($args->{'label3'}||'')), min3 => $self->make_kvl($args,($args->{'min3'}||'0')), max3 => $self->make_kvl($args,($args->{'max3'}||'100')), def3 => $self->make_kvl($args,($args->{'def3'}||'0')), ); my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } # --spinbox <text> <height> <width> <min> <max> <def> <label> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a spin box (a number with up/down buttons) with preset ranges sub spinbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'min'} ||= $self->{'min1'}; $self->{'max'} ||= $self->{'max1'}; $self->{'def'} ||= $self->{'def1'}; $self->{'label'} ||= $self->{'label1'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --spinbox {{text}} {{height}} {{width}}'); $fmt = $self->append_format($fmt,'{{min}} {{max}} {{def}} {{label}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), min => $self->make_kvl($args,($args->{'min'}||'0')), max => $self->make_kvl($args,($args->{'max'}||'100')), def => $self->make_kvl($args,($args->{'def'}||'0')), label => $self->make_kvl($args,($args->{'label'}||'')), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } # --2spinsbox <text> <height> <width> <min1> <max1> <def1> <label1> <min2> <max2> <def2> <label2> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display two spin boxes with preset ranges and labels sub spinsbox2 { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --2spinsbox {{text}} {{height}} {{width}}'); $fmt = $self->append_format($fmt,'{{min1}} {{max1}} {{def1}} {{label1}}'); $fmt = $self->append_format($fmt,'{{min2}} {{max2}} {{def2}} {{label2}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), label1 => $self->make_kvl($args,($args->{'label1'}||'')), min1 => $self->make_kvl($args,($args->{'min1'}||'0')), max1 => $self->make_kvl($args,($args->{'max1'}||'100')), def1 => $self->make_kvl($args,($args->{'def1'}||'0')), label2 => $self->make_kvl($args,($args->{'label2'}||'')), min2 => $self->make_kvl($args,($args->{'min2'}||'0')), max2 => $self->make_kvl($args,($args->{'max2'}||'100')), def2 => $self->make_kvl($args,($args->{'def2'}||'0')), ); my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } # --3spinsbox <text> <height> <width> <text> <height> <width> <min1> <max1> <def1> <label1> <min2> <max2> <def2> <label2> <min3> <max3> <def3> <label3> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display three spin boxes with preset ranges and labels sub spinsbox3 { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --3spinsbox {{text}} {{height}} {{width}}'); $fmt = $self->append_format($fmt,'{{min1}} {{max1}} {{def1}} {{label1}}'); $fmt = $self->append_format($fmt,'{{min2}} {{max2}} {{def2}} {{label2}}'); $fmt = $self->append_format($fmt,'{{min3}} {{max3}} {{def3}} {{label3}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), label1 => $self->make_kvl($args,($args->{'label1'}||'')), min1 => $self->make_kvl($args,($args->{'min1'}||'0')), max1 => $self->make_kvl($args,($args->{'max1'}||'100')), def1 => $self->make_kvl($args,($args->{'def1'}||'0')), label2 => $self->make_kvl($args,($args->{'label2'}||'')), min2 => $self->make_kvl($args,($args->{'min2'}||'0')), max2 => $self->make_kvl($args,($args->{'max2'}||'100')), def2 => $self->make_kvl($args,($args->{'def2'}||'0')), label3 => $self->make_kvl($args,($args->{'label3'}||'')), min3 => $self->make_kvl($args,($args->{'min3'}||'0')), max3 => $self->make_kvl($args,($args->{'max3'}||'100')), def3 => $self->make_kvl($args,($args->{'def3'}||'0')), ); my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } # --buildlist <text> <height> <width> <list height> <tag1> <item1> <status1> {<help1>}... #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a two paned box by which the user can organize a list of items sub buildlist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'buildlist'} ||= 'buildlist'; $self->{'listheight'} ||= $self->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --'.$self->{'buildlist'}); $fmt = $self->append_format('{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } # --treeview <text> <height> <width> <list height> <tag1> <item1> <status1> <item_depth1> {<help1>}... #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a tree view of items sub treeview { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'treeview'} ||= 'treeview'; $self->{'listheight'} ||= $self->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --'.$self->{'treeview'}); $fmt = $self->append_format('{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } # --calendar <text> <height> <width> <day> <month> <year> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a calendar with a preset date sub calendar { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'day'} ||= '1'; $args->{'month'} ||= '1'; $args->{'year'} ||= '1970'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --calendar {{text}} {{height}} {{width}} {{day}} {{month}} {{year}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$date) = $self->command_string($command); if ($rv == 0) { $self->ra(split(m!/!,$date)); } $self->_post($args); return($rv == 0 ? $date : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0,0,0)); } # --timebox <text> <height> <width> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a time box sub timebox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --timebox {{text}} {{height}} {{width}} {{hour}} {{minute}} {{second}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$time) = $self->command_string($command); if ($rv == 0) { $self->ra(split(m!\:!,$time)); } $self->_post($args); return($rv == 0 ? $time : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0,0,0)); } # --yesno <text> <height> <width> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Ask a binary question (Yes/No) sub yesno { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--yesno {{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); } else { $self->ra("YES"); $self->rs("YES"); } $self->_post($args); return($rv == 0 ? 1 : 0); } # --inputbox <text> <height> <width> [<init>] # --2inputsbox <text> <height> <width> <label1> <init1> <label2> <init2> # --3inputsbox <text> <height> <width> <label1> <init1> <label2> <init2> <label3> <init3> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text entry sub inputbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $num_fields = $args->{'inputs'} || $args->{'password'} || 1; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); if ($num_fields > 1) { $fmt = $self->append_format($fmt,'--separate-output'); } $fmt = $self->append_format_check($args,$fmt,'password','--password'); $fmt = $self->append_format_check($args,$fmt,'password','--password') if $num_fields > 1; $fmt = $self->append_format_check($args,$fmt,'password','--password') if $num_fields > 2; my $opbox = '--inputbox'; $opbox = '--2inputsbox' if $num_fields == 2; $opbox = '--3inputsbox' if $num_fields == 3; $fmt = $self->append_format($fmt,$opbox.' {{text}} {{height}} {{width}}'); $fmt = $self->append_format($fmt,shell_quote($args->{'entry'}||$args->{'init'})) if $num_fields == 1; $fmt = $self->append_format($fmt,shell_quote($args->{'label1'}||'')) if $num_fields > 1; $fmt = $self->append_format($fmt,shell_quote($args->{'input1'}||'')) if $num_fields > 1; $fmt = $self->append_format($fmt,shell_quote($args->{'label2'}||'')) if $num_fields >= 2; $fmt = $self->append_format($fmt,shell_quote($args->{'input2'}||'')) if $num_fields >= 2; $fmt = $self->append_format($fmt,shell_quote($args->{'label3'}||'')) if $num_fields >= 3; $fmt = $self->append_format($fmt,shell_quote($args->{'input3'}||'')) if $num_fields >= 3; my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$text); if ($num_fields == 1) { ($rv,$text) = $self->command_string($command); return($rv == 0 ? $text : 0); } ($rv,$text) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $text : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } sub inputsbox2 { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'inputs',2)); } sub inputsbox3 { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'inputs',3)); } sub password { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'password',1,'inputs',1)); } sub passwords2 { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'password',1,'inputs',2)); } sub passwords3 { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'password',1,'inputs',3)); } # --msgbox <text> <height> <width> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text box sub msgbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'msgbox'} ||= 'msgbox'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--'.$args->{'msgbox'}); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}}'); my $wait = ($args->{'wait'} ? $args->{'wait'}*1000 : ($args->{'timeout'}||'5000')); $fmt = $self->append_format($fmt,shell_quote($wait)) if $args->{'msgbox'} eq 'infobox'; my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); $self->_post($args); return($rv == 0 ? 1 : 0); } # --infobox <text> <height> <width> [<timeout>] #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: same as msgbox but destroy's itself with timeout... sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'msgbox','infobox')); } # --editbox <file> <height> <width> # --tailbox <file> <height> <width> # --logbox <file> <height> <width> # --textbox <file> <height> <width> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: File box sub textbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'textbox'} ||= 'textbox'; $args->{'filename'} ||= $args->{'path'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--'.$args->{'textbox'}); $fmt = $self->append_format($fmt,'{{filename}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, filename => $self->make_kvl($args,$args->{'filename'}), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $text : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } sub editbox { my $self = shift(); return($self->textbox('caller',((caller(1))[3]||'main'),@_,'textbox','editbox')); } sub logbox { my $self = shift(); return($self->textbox('caller',((caller(1))[3]||'main'),@_,'textbox','logbox')); } sub tailbox { my $self = shift(); return($self->textbox('caller',((caller(1))[3]||'main'),@_,'textbox','tailbox')); } # --menubox <text> <height> <width> <menu height> <tag1> <item1> {<help1>}... #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Lists sub menu { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --menu'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } # --checklist <text> <height> <width> <list height> <tag1> <item1> <status1> {<help1>}... #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: multiple selection list via checkbox widgets sub checklist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'checklist'} ||= 'checklist'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --'.$self->{'checklist'}); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_array($command); $self->_post($args); return($rv == 0 ? $selected : 0) unless defined wantarray and wantarray; return($rv == 0 ? $self->ra() : (0)); } # --radiolist <text> <height> <width> <list height> <tag1> <item1> <status1> {<help1>}... #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: display a list via the radiolist widget sub radiolist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'radiolist'} ||= 'radiolist'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output --'.$self->{'radiolist'}); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } # --fselect <file> <height> <width> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: file select sub fselect { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'path'} ||= abs_path(); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--fselect'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,$args->{'path'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } # --dselect <directory> <height> <width> #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: directory selector sub dselect { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'path'} ||= abs_path(); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--dselect'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,$args->{'path'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } # --gauge <text> <height> <width> [<percent>] # --progress <text> <height> <width> [<maxdots> [[-]<msglen>]] #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: progress meter sub progress_start { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'_PROGRESS'} ||= {}; $self->{'_PROGRESS'}->{'ARGS'} = $args; if (defined $self->{'_PROGRESS'}->{'FH'}) { $self->rv(129); $self->_post($args); return(0); } my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--progress'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}}'); $fmt = $self->append_format($fmt,shell_quote($args->{'maxdots'}||'')) if $args->{'maxdots'} or $args->{'msglen'}; $fmt = $self->append_format($fmt,shell_quote($args->{'msglen'}||'')) if $args->{'msglen'}; my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); $self->{'_PROGRESS'}->{'PERCENT'} = ($args->{'percentage'} || '0'); $self->_debug("command: ".$command,2); $self->{'_PROGRESS'}->{'FH'} = new FileHandle; $self->{'_PROGRESS'}->{'FH'}->open("| $command"); my $rv = $? >> 8; $self->{'_PROGRESS'}->{'FH'}->autoflush(1); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); return($rv == 0 ? 1 : 0); } sub gauge_start { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'_GAUGE'} ||= {}; $self->{'_GAUGE'}->{'ARGS'} = $args; if (defined $self->{'_GAUGE'}->{'FH'}) { $self->rv(129); $self->_post($args); return(0); } my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--progress'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{percentage}}'); $fmt = $self->append_format($fmt,shell_quote($args->{'msglen'}||'')) if $args->{'msglen'}; my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), percentage => $self->make_kvl($args,($args->{'percentage'}||'0')), ); $self->{'_GAUGE'}->{'PERCENT'} = ($args->{'percentage'} || '0'); $self->_debug("command: ".$command,2); $self->{'_GAUGE'}->{'FH'} = new FileHandle; $self->{'_GAUGE'}->{'FH'}->open("| $command"); my $rv = $? >> 8; $self->{'_GAUGE'}->{'FH'}->autoflush(1); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); return($rv == 0 ? 1 : 0); } sub progress_inc { my $self = $_[0]; my $incr = $_[1] || 1; return(0) unless defined $self->{'_PROGRESS'}->{'FH'}; my $fh = $self->{'_PROGRESS'}->{'FH'}; $self->{'_PROGRESS'}->{'PERCENT'} += $incr; $SIG_CODE->{'PROGRESS'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_progress; print $fh $self->{'_PROGRESS'}->{'PERCENT'}."\n"; return(((defined $self->{'_PROGRESS'}->{'FH'}) ? 1 : 0)); } sub gauge_inc { my $self = $_[0]; my $incr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} += $incr; $SIG_CODE->{'GAUGE'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub progress_dec { my $self = $_[0]; my $decr = $_[1] || 1; return(0) unless defined $self->{'_PROGRESS'}->{'FH'}; my $fh = $self->{'_PROGRESS'}->{'FH'}; $self->{'_PROGRESS'}->{'PERCENT'} -= $decr; $SIG_CODE->{'PROGRESS'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_progress; print $fh $self->{'_PROGRESS'}->{'PERCENT'}."\n"; return(((defined $self->{'_PROGRESS'}->{'FH'}) ? 1 : 0)); } sub gauge_dec { my $self = $_[0]; my $decr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} -= $decr; $SIG_CODE->{'GAUGE'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub progress_set { my $self = $_[0]; my $perc = $_[1] || $self->{'_PROGRESS'}->{'PERCENT'} || 1; return(0) unless defined $self->{'_PROGRESS'}->{'FH'}; my $fh = $self->{'_PROGRESS'}->{'FH'}; $self->{'_PROGRESS'}->{'PERCENT'} = $perc; $SIG_CODE->{'PROGRESS'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_progress; print $fh $self->{'_PROGRESS'}->{'PERCENT'}."\n"; return(((defined $self->{'_PROGRESS'}->{'FH'}) ? 1 : 0)); } sub gauge_set { my $self = $_[0]; my $perc = $_[1] || $self->{'_GAUGE'}->{'PERCENT'} || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} = $perc; $SIG_CODE->{'GAUGE'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_text { my $self = $_[0]; my $mesg = $_[1] || return(0); return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh "\nXXX\n\n".$mesg."\n\nXXX\n\n".$self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub progress_stop { my $self = $_[0]; return(0) unless defined $self->{'_PROGRESS'}->{'FH'}; my $args = $self->{'_PROGRESS'}->{'ARGS'}; my $fh = $self->{'_PROGRESS'}->{'FH'}; $SIG_CODE->{'PROGRESS'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_progress; $self->{'_PROGRESS'}->{'FH'}->close(); delete($self->{'_PROGRESS'}->{'FH'}); delete($self->{'_PROGRESS'}->{'PERCENT'}); delete($self->{'_PROGRESS'}->{'ARGS'}); delete($self->{'_PROGRESS'}); $self->rv('null'); $self->rs('null'); $self->ra('null'); $self->_post($args); return(1); } sub gauge_stop { my $self = $_[0]; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $args = $self->{'_GAUGE'}->{'ARGS'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $SIG_CODE->{'GAUGE'}->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; $self->{'_GAUGE'}->{'FH'}->close(); delete($self->{'_GAUGE'}->{'FH'}); delete($self->{'_GAUGE'}->{'PERCENT'}); delete($self->{'_GAUGE'}->{'ARGS'}); delete($self->{'_GAUGE'}); $self->rv('null'); $self->rs('null'); $self->ra('null'); $self->_post($args); return(1); } 1; PK ! �c�|r. r. Dialog/Backend/CDialog.podnu ��6�$ =head1 NAME UI::Dialog::Backend::CDialog - backend for the console dialog(1) variant. =head1 SYNOPSIS use UI::Dialog::Backend::CDialog; my $d = new UI::Dialog::Backend::CDialog ( backtitle => 'Demo', title => 'Default' ); $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Backend::CDialog is the UI::Dialog backend for the console dialog variant. While this module is used through UI::Dialog or any other loader module only the compatible methods are ever accessible. However, when using this module directly in your application (as in the SYNOPSIS example) you are given access to all the options and features of the real dialog(1) application. =head1 DESCRIPTION There are essentially two versions of the console dialog program. One has support for colours as well as extra widgets, while the other does not have either. You can read about the colour support in the TEXT MARKUP section. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5 ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::CDialog class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<literal = 0,1> (0) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<height = \d+> (0) * =item B<width = \d+> (0) * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =back =back =head1 WIDGET METHODS =head2 yesno( ) =over 4 =item EXAMPLE =over 6 if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, yes and no. =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 infobox( ) =over 4 =item EXAMPLE =over 6 $d->infobox( text => 'A simple 6 second message.', timeout => 6000 ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box for a limited duration of time. The timeout is specified in thousandths of a second, ie: 1000 = 1 second. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some (hidden) text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field that doesn't reveal the input (except to the script) and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Please enter some text.', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 form( ) =over 4 =item EXAMPLE =over 6 my @data = $d->form( text => 'Select one:', list => [ [ 'tag1', 1, 1 ], [ 'item1', 1, 10, 10, 10 ], [ 'tag2', 2, 1 ], [ 'item2', 2, 10, 10, 10 ], [ 'tag3', 3, 1 ], [ 'item3', 3, 10, 10, 10 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable and potentially editable form. =back =item RETURNS =over 6 an ARRAY of the form data if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 calendar( ) =over 4 =item EXAMPLE =over 6 my $date = $d->calendar( text => 'Pick a date...', day => 1, month => 1, year => 1970 ); my ($m,$d,$y) = split(/\//,$date); # or alternatively... $d->calendar( text => 'Pick a date...', day => 1, month => 1, year => 1970 ); ($m,$d,$y) = $d->ra(); =back =item DESCRIPTION =over 6 Present the user with a calendar widget preset with the given date or if none is specified, use the current date. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 timebox( ) =over 4 =item EXAMPLE =over 6 my $time = $d->timebox( text => 'What time?' ); my ($h,$m,$s) = split(/\:/,$time); # or alternatively... $d->timebox( text => 'What time?', hour => 10, minute => 01, second => 01 ); my ($h,$m,$s) = $d->ra(); =back =item DESCRIPTION =over 6 Present the user with a time widget preset with the current time. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 tailbox( ) =over 4 =item EXAMPLE =over 6 $d->tailbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a scrolling box containing the contents of the given text file. The contents of the window is constantly updated in a similar manner to that of the unix tail(1) command. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 gauge_start( ) =over 4 =item EXAMPLE =over 6 $d->gauge_start( text => 'gauge...', percentage => 1 ); =back =item DESCRIPTION =over 6 Display a meter bar to the user. This get's the widget realized but requires the use of the other gauge_*() methods for functionality. =back =item RETURNS =over 6 TRUE (1) if the widget loaded fine and FALSE (0) for anything else. =back =back =head2 gauge_inc( ) =over 4 =item EXAMPLE =over 6 $d->gauge_inc( 1 ); =back =item DESCRIPTION =over 6 Increment the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_dec( ) =over 4 =item EXAMPLE =over 6 $d->gauge_dec( 1 ); =back =item DESCRIPTION =over 6 Decrement the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_set( ) =over 4 =item EXAMPLE =over 6 $d->gauge_set( 99 ); =back =item DESCRIPTION =over 6 Set the meter bar to the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_text( ) =over 4 =item EXAMPLE =over 6 $d->gauge_text( 'string' ); =back =item DESCRIPTION =over 6 Set the meter bar message to the given string. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_stop( ) =over 4 =item EXAMPLE =over 6 $d->gauge_stop(); =back =item DESCRIPTION =over 6 End the meter bar widget process. One of the flaws with gdialog is that the gauge widget does not close properly and requies the end user to close the gauge window when 100% has been reached. This is the second reason why I'm glad gdialog is going the way of the dodo. =back =item RETURNS =over 6 TRUE (1) if the widget closed fine and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Console UI::Dialog::Backend =back =over 2 =item MAN FILES dialog(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! 5[��-- -- Dialog/Backend/XOSD.pmnu ��6�$ package UI::Dialog::Backend::XOSD; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use UI::Dialog::Backend; use FileHandle; #: Ideas: # - implement debugging code... # - what about tail("/file")? # - and my $fh = tail_pipe() ? # (or pipe_start(), pipe_print() and pipe_close()) # - now here's a kicker, what about a "valid fonts" list and a # suitable mechanism to use (and cache) `xlsfonts` to determine # the font to use. Once the decision is made the decision should # simply be enforced rather than revalidated again and again. BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_opts'} = {}; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'bin'} = $self->_find_bin('osd_cat'); $self->{'_opts'}->{'tail'} = $self->_find_bin('tail'); $self->{'_opts'}->{'kill'} = $self->_find_bin('kill'); $self->{'_opts'}->{'pos'} = $cfg->{'pos'} || undef(); $self->{'_opts'}->{'offset'} = $cfg->{'offset'} || 0; $self->{'_opts'}->{'align'} = $cfg->{'align'} || undef(); $self->{'_opts'}->{'indent'} = $cfg->{'indent'} || 0; $self->{'_opts'}->{'font'} = $cfg->{'font'} || undef(); $self->{'_opts'}->{'colour'} = $cfg->{'colour'} || $cfg->{'color'} || undef(); $self->{'_opts'}->{'delay'} = $cfg->{'delay'} || 0; $self->{'_opts'}->{'lines'} = $cfg->{'lines'} || 0; $self->{'_opts'}->{'shadow'} = $cfg->{'shadow'} || 0; $self->{'_opts'}->{'age'} = $cfg->{'age'} || 0; $self->{'_opts'}->{'wait'} = ($cfg->{'wait'}) ? 1 : 0; $self->{'_opts'}->{'length'} = $cfg->{'wait'} || 40; $self->{'_opts'}->{'bar'} = $cfg->{'bar'} || "-"; $self->{'_opts'}->{'mark'} = $cfg->{'mark'} || "|"; unless (-x $self->{'_opts'}->{'bin'}) { croak("the osd_cat binary could not be found at: ".$self->{'_opts'}->{'bin'}); } $self->{'_opts'}->{'trust-input'} = ( exists $cfg->{'trust-input'} && $cfg->{'trust-input'}==1 ) ? 1 : 0; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Internal Methods #: my $SIG_CODE = {}; sub _del_display { my $CODE = $SIG_CODE->{$$}; unless (not ref($CODE)) { delete($CODE->{'_DISPLAY'}); $SIG_CODE->{$$} = ""; } } sub _gen_opt_str { my $self = shift(); my $args = shift(); my $string = ""; if ($args->{'pos'}) { my $pos = ($args->{'pos'} =~ /^top|middle|bottom$/i) ? lc($args->{'pos'}) : 'top'; $string .= " --pos='".$pos."'"; } if ($args->{'offset'}) { my $offset = ($args->{'offset'} =~ /^\d+$/) ? $args->{'offset'} : 0; $string .= " --offset='".$offset."'"; } if ($args->{'align'}) { my $align = ($args->{'align'} =~ /^left|center|right$/i) ? lc($args->{'align'}) : 'left'; $string .= " --align='".$align."'"; } if ($args->{'indent'}) { my $indent = ($args->{'indent'} =~ /^\d+$/) ? $args->{'indent'} : 0; $string .= " --indent='".$indent."'"; } if ($args->{'font'}) { my $font = $args->{'font'} || "-*-fixed-*-*-*-*-*-*-*-*-*-*-*-*"; $string .= " --font='".$font."'"; } if ($args->{'colour'}) { my $colour = $args->{'colour'} || "green"; $string .= " --color='".$colour."'"; } if ($args->{'delay'}) { my $delay = ($args->{'delay'} =~ /^\d+$/) ? $args->{'delay'} : 5; $string .= " --delay='".$delay."'"; } if ($args->{'lines'}) { my $lines = ($args->{'lines'} =~ /^\d+$/) ? $args->{'lines'} : 5; $string .= " --lines='".$lines."'"; } if ($args->{'shadow'}) { my $shadow = ($args->{'shadow'} =~ /^\d+$/) ? $args->{'shadow'} : 0; $string .= " --shadow='".$shadow."'"; } if ($args->{'age'}) { my $age = ($args->{'age'} =~ /^\d+$/) ? $args->{'age'} : 0; $string .= " --age='".$age."'"; } if ($args->{'wait'}) { $string .= " --wait"; } $self->_debug("xosd: ".$string,3); return($string||" "); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: sub line { my $self = shift(); my $args = $self->_merge_attrs(@_); my $opts = $self->_gen_opt_str($args); if (open(XOSD,"| ".$self->{'_opts'}->{'bin'}.$opts." -")) { print XOSD ($args->{'text'}||'')."\n"; close(XOSD); } else { croak("failed to open osd_cat output pipe!"); } } sub file { my $self = shift(); my $args = $self->_merge_attrs(@_); my $opts = $self->_gen_opt_str($args); if (-r $args->{'file'}) { if (open(FILE,"<".$args->{'file'})) { local $/; my $text = <FILE>; close(FILE); $text =~ s!\t! !g; if (open(XOSD,"| ".$self->{'_opts'}->{'bin'}.$opts." -")) { print XOSD ($text||'')."\n"; close(XOSD); } else { croak("failed to open osd_cat output pipe!"); } } } } sub gauge { my $self = shift(); my $args = $self->_merge_attrs(@_); my $opts = $self->_gen_opt_str($args); my $length = $args->{'length'} || 40; my $bar = ($args->{'bar'} || "-") x $length; my $percent = $args->{'percent'} || '0'; $percent = (($percent <= 100 && $percent >= 0) ? $percent : 0 ); my $perc = int((($length / 100) * $percent)); substr($bar,($perc||0),1,($args->{'mark'}||"|")); my $text = $args->{'text'} ? $args->{'text'}."\n" : ''; $text .= $percent."% ".$bar."\n"; if (open(XOSD,"| ".$self->{'_opts'}->{'bin'}.$opts." -")) { print XOSD $text; close(XOSD); } else { croak("failed to open osd_cat output pipe!"); } } sub display_start { my $self = shift(); my $args = $self->_merge_attrs(@_); my $opts = $self->_gen_opt_str($args); $self->{'_DISPLAY'} ||= {}; $self->{'_DISPLAY'}->{'ARGS'} = $args; return(0) if defined $self->{'_DISPLAY'}->{'FH'}; my $command = $self->{'_opts'}->{'bin'}.$opts." -"; $self->{'_DISPLAY'}->{'FH'} = new FileHandle; $self->{'_DISPLAY'}->{'FH'}->open("| $command"); my $rv = $? >> 8; $self->{'_DISPLAY'}->{'FH'}->autoflush(1); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } return($this_rv); } sub display_text { my $self = shift(); my $mesg; if (@_ > 1) { $mesg = join("\n",@_); } elsif (ref($_[0]) eq "ARRAY") { $mesg = join("\n",@{$_[0]}); } else { $mesg = $_[0] || return(0); } return(0) unless $self->{'_DISPLAY'}->{'FH'}; my $fh = $self->{'_DISPLAY'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $mesg."\n"; return(((defined $self->{'_DISPLAY'}->{'FH'}) ? 1 : 0)); } sub display_gauge { my $self = $_[0]; return(0) unless $self->{'_DISPLAY'}->{'FH'}; my $args = $self->_merge_attrs(); my $length = $args->{'length'} || 40; my $bar = ($args->{'bar'} || "-") x $length; my $percent = $_[1] || 0; $percent = (($percent <= 100 && $percent >= 0) ? $percent : 0 ); my $perc = int((($length / 100) * $percent)); substr($bar,($perc||0),1,($args->{'mark'}||"|")); my $text = $_[2] ? $_[2]."\n" : ''; $text .= $percent."% ".$bar."\n"; my $fh = $self->{'_DISPLAY'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $text; return(((defined $self->{'_DISPLAY'}->{'FH'}) ? 1 : 0)); } sub display_stop { my $self = shift(); return(0) unless $self->{'_DISPLAY'}->{'FH'}; my $args = $self->{'_DISPLAY'}->{'ARGS'}; my $fh = $self->{'_DISPLAY'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; $self->{'_DISPLAY'}->{'FH'}->close(); delete($self->{'_DISPLAY'}->{'FH'}); delete($self->{'_DISPLAY'}->{'ARGS'}); delete($self->{'_DISPLAY'}->{'PERCENT'}); delete($self->{'_DISPLAY'}); return(1); } # #$d->tail( file => "/tmp/xosdtail.log", delay => '3' ); # sub tail { # my $self = shift(); # my $args = $self->_merge_attrs(@_); # my $opts = $self->_gen_opt_str($args); # if (-r $args->{'file'}) { # my $tail_cmnd = $self->{'_opts'}->{'tail'}.' -f '.$args->{'file'}; # system($tail_cmnd." | ".$self->{'_opts'}->{'bin'}.$opts." -"); # } else { # $self->line( @_, text => "couldn't open file: ".($args->{'file'}||'NULL') ); # } # } # sub tailbg { # my $self = shift(); # my $args = $self->_merge_attrs(@_); # my $opts = $self->_gen_opt_str($args); # if (-r $args->{'file'}) { # my $tail_cmnd = $self->{'_opts'}->{'tail'}.' -f '.$args->{'file'}; # my $xosd_cmnd = $self->{'_opts'}->{'bin'}.$opts." -"; # # system($tail_cmnd." | ".$self->{'_opts'}->{'bin'}.$opts." - &"); # # $self->{'forkpid'} = $self->command_forked($tail_cmnd." | ".$self->{'_opts'}->{'bin'}.$opts." -"); # # $self->{'forkpid'} = $self->command_forked($self->{'_opts'}->{'tail'},' -f '.$args->{'file'}. " | ".$self->{'_opts'}->{'bin'}.$opts." -"); # $self->{'forkpid'} = $self->tailbg_forked($tail_cmnd,$xosd_cmnd); # print "pid: ".$self->{'forkpid'}."\n"; # return(1) if $self->{'forkpid'}; # return(0); # } else { # $self->line( @_, text => "couldn't open file: ".($args->{'file'}||'NULL') ); # } # } # sub command_forked { # my $self = shift(); # if (my $pid = fork()) { return($pid); } # else { exec(@_); } # } # sub tailbg_forked { # my $self = shift(); # my $tail = shift(); # my $osdc = shift(); # if (my $pid = fork()) { return($pid); } # else { # # here we open the tail and read # # while reading, print to an open osd_cat # my $TSIGP = $SIG{'PIPE'}; # $SIG{'PIPE'} = "IGNORE"; # if (open(TAIL,$tail." |")) { # unless (open(OSDC,"| ".$osdc)) { # close(TAIL); # return(); # } # my $TP = $|; # $| = 1; # while (my $line = <TAIL>) { # print OSDC $line; # } # $| = $TP; # close(OSDC); # close(TAIL); # } # $SIG{'PIPE'} = $TSIGP; # } # } # sub tailbg_end { # my $self = shift(); # my $args = $self->_merge_attrs(@_); # if ($self->{'forkpid'}) { # print "pid: ".$self->{'forkpid'}."\n"; # if (kill(15,$self->{'forkpid'})) { # print "killed: ".$self->{'forkpid'}."\n"; # } else { # print "maimed: ".$self->{'forkpid'}."\n"; # } # } # } 1; PK ! C���2 �2 Dialog/Backend/KDialog.pmnu ��6�$ package UI::Dialog::Backend::KDialog; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use Cwd qw( abs_path ); use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_state'} = {}; $self->{'_opts'} = {}; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'literal'} = $cfg->{'literal'} || 0; $self->{'_opts'}->{'callbacks'} = $cfg->{'callbacks'} || undef(); $self->{'_opts'}->{'debug'} = $cfg->{'debug'} || undef(); $self->{'_opts'}->{'caption'} = $cfg->{'caption'} || undef(); $self->{'_opts'}->{'icon'} = $cfg->{'icon'} || undef(); $self->{'_opts'}->{'miniicon'} = $cfg->{'miniicon'} || undef(); $self->{'_opts'}->{'title'} = $cfg->{'title'} || undef(); $self->{'_opts'}->{'width'} = $cfg->{'width'} || 65; $self->{'_opts'}->{'height'} = $cfg->{'height'} || 10; $self->{'_opts'}->{'bin'} ||= $self->_find_bin('kdialog'); $self->{'_opts'}->{'autoclear'} = $cfg->{'autoclear'} || 0; $self->{'_opts'}->{'clearbefore'} = $cfg->{'clearbefore'} || 0; $self->{'_opts'}->{'clearafter'} = $cfg->{'clearafter'} || 0; $self->{'_opts'}->{'beepbin'} = $cfg->{'beepbin'} || $self->_find_bin('beep') || '/usr/bin/beep'; $self->{'_opts'}->{'beepbefore'} = $cfg->{'beepbefore'} || 0; $self->{'_opts'}->{'beepafter'} = $cfg->{'beepafter'} || 0; $self->{'_opts'}->{'timeout'} = $cfg->{'timeout'} || 0; $self->{'_opts'}->{'wait'} = $cfg->{'wait'} || 0; unless (-x $self->{'_opts'}->{'bin'}) { croak("the kdialog binary could not be found at: ".$self->{'_opts'}->{'bin'}); } $self->{'_opts'}->{'trust-input'} = $cfg->{'trust-input'} || 0; $self->{'test_mode'} = $cfg->{'test_mode'} if exists $cfg->{'test_mode'}; $self->{'test_mode_result'} = ''; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: sub append_format_base { my ($self,$args,$fmt) = @_; $fmt = $self->append_format_check($args,$fmt,'caption','--caption {{caption}}'); $fmt = $self->append_format_check($args,$fmt,'icon','--icon {{icon}}'); $fmt = $self->append_format_check($args,$fmt,'miniicon','--miniicon {{miniicon}}'); if ($self->{'_opts'}->{'force-no-separate-output'}) { delete $args->{'separate-output'}; } else { $fmt = $self->append_format_check($args,$fmt,"separate-output","--separate-output"); } return $fmt; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Ask a binary question (Yes/No) sub yesno { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'yesno'} ||= "yesno"; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--'.$args->{'yesno'}.' {{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $self->rv($rv); } else { $self->ra("YES"); $self->rs("YES"); $self->rv('null'); } $self->_post($args); return($rv == 0 ? 1 : 0); } sub yesnocancel { my $self = shift(); return($self->yesno('caller',((caller(1))[3]||'main'),@_,'yesno','yesnocancel')); } sub warningyesno { my $self = shift(); return($self->yesno('caller',((caller(1))[3]||'main'),@_,'yesno','warningyesno')); } sub warningyesnocancel { my $self = shift(); return($self->yesno('caller',((caller(1))[3]||'main'),@_,'yesno','warningyesnocancel')); } #: Broken documented "feature" # sub warningcontinuecancel { # my $self = shift(); # return($self->yesno(@_,'yesno','warningcontinuecancel')); # } sub noyes { my $self = shift(); return($self->yesno('caller',((caller(1))[3]||'main'),@_)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text entry sub inputbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'inputbox'} ||= 'inputbox'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--'.$args->{'inputbox'}.' {{text}} {{entry}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), entry => $self->make_kvl($args,($args->{'init'}||$args->{'entry'})), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $text : 0); } sub password { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'inputbox','password')); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text box sub msgbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'msgbox'} ||= 'msgbox'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--'.$args->{'msgbox'}.' {{text}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); $self->_post($args); return($rv == 0 ? 1 : 0); } sub error { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'msgbox','error')); } sub sorry { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'msgbox','sorry')); } sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'msgbox','msgbox')); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: File box sub textbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--textbox'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'filename'}||$args->{'path'}||'.')), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a simple menu sub menu { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output'); $fmt = $self->append_format($fmt,'--menu'); $fmt = $self->append_format($fmt,'{{text}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a check list sub checklist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} = $args->{'menuheight'} if exists $args->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $args->{radiolist} ||= 0; if ($args->{radiolist}) { $fmt = $self->append_format($fmt,'--radiolist'); } else { $fmt = $self->append_format($fmt,'--separate-output'); $fmt = $self->append_format($fmt,'--checklist'); } $fmt = $self->append_format($fmt,'{{text}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); if ($args->{radiolist}) { my ($rv,$selected) = $self->command_string($command); return($rv == 0 ? $selected : 0); } my ($rv,$selected) = $self->command_array($command); return($rv == 0 ? @{$selected} : 0); } #: a radio button list sub radiolist { my $self = shift(); return($self->checklist('caller',((caller(1))[3]||'main'),@_,'radiolist',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: file select sub fselect { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'fselect'} ||= 'getopenfilename'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output'); $fmt = $self->append_format($fmt,'--'.$args->{'fselect'}); if ($args->{'getexistingdirectory'}) { $fmt = $self->append_format($fmt,'{{path}}'); } else { $fmt = $self->append_format($fmt,'{{path}} {{filter}}'); } my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'path'}||abs_path())), filter => $self->make_kvl($args,($args->{'filter'}||'*')) ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } sub getopenfilename { my $self = shift(); return($self->fselect('caller',((caller(1))[3]||'main'),@_,'fselect','getopenfilename')); } sub getsavefilename { my $self = shift(); return($self->fselect('caller',((caller(1))[3]||'main'),@_,'fselect','getsavefilename')); } sub getopenurl { my $self = shift(); return($self->fselect('caller',((caller(1))[3]||'main'),@_,'fselect','getopenurl')); } sub getsaveurl { my $self = shift(); return($self->fselect('caller',((caller(1))[3]||'main'),@_,'fselect','getsaveurl')); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: directory select sub dselect { my $self = shift(); return($self->fselect('caller',((caller(1))[3]||'main'),@_,'fselect','getexistingdirectory')); } sub getexistingdirectory { my $self = shift(); return($self->fselect('caller',((caller(1))[3]||'main'),@_,'fselect','getexistingdirectory')); } 1; PK ! ��u�' �' Dialog/Backend/GDialog.pmnu ��6�$ package UI::Dialog::Backend::GDialog; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use FileHandle; use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_state'} = {}; $self->{'_opts'} = {}; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'literal'} = $cfg->{'literal'} || 0; $self->{'_opts'}->{'callbacks'} = $cfg->{'callbacks'} || undef(); $self->{'_opts'}->{'debug'} = $cfg->{'debug'} || undef(); $self->{'_opts'}->{'title'} = $cfg->{'title'} || undef(); $self->{'_opts'}->{'backtitle'} = $cfg->{'backtitle'} || undef(); $self->{'_opts'}->{'width'} = $cfg->{'width'} || 65; $self->{'_opts'}->{'height'} = $cfg->{'height'} || 10; $self->{'_opts'}->{'percentage'} = $cfg->{'percentage'} || 1; $self->{'_opts'}->{'bin'} ||= $self->_find_bin('gdialog.real') || $self->_find_bin('gdialog') || '/usr/bin/gdialog'; $self->{'_opts'}->{'autoclear'} = $cfg->{'autoclear'} || 0; $self->{'_opts'}->{'clearbefore'} = $cfg->{'clearbefore'} || 0; $self->{'_opts'}->{'clearafter'} = $cfg->{'clearafter'} || 0; $self->{'_opts'}->{'beepbin'} = $cfg->{'beepbin'} || $self->_find_bin('beep') || '/usr/bin/beep'; $self->{'_opts'}->{'beepbefore'} = $cfg->{'beepbefore'} || 0; $self->{'_opts'}->{'beepafter'} = $cfg->{'beepafter'} || 0; $self->{'_opts'}->{'timeout'} = $cfg->{'timeout'} || 0; $self->{'_opts'}->{'wait'} = $cfg->{'wait'} || 0; unless (-x $self->{'_opts'}->{'bin'}) { croak("the gdialog binary could not be found at: ".$self->{'_opts'}->{'bin'}); } $self->{'_opts'}->{'trust-input'} = $cfg->{'trust-input'} || 0; $self->{'test_mode'} = $cfg->{'test_mode'} if exists $cfg->{'test_mode'}; $self->{'test_mode_result'} = ''; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: my $SIG_CODE = {}; sub _del_gauge { my $CODE = $SIG_CODE->{$$}; unless (not ref($CODE)) { delete($CODE->{'_GAUGE'}); $CODE->rv('1'); $CODE->rs('null'); $CODE->ra('null'); $SIG_CODE->{$$} = ""; } } sub append_format_base { my ($self,$args,$fmt) = @_; return $fmt; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Ask a binary question (Yes/No) sub yesno { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--yesno {{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $self->rv($rv); } else { $self->ra("YES"); $self->rs("YES"); $self->rv('null'); } $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text entry sub inputbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--inputbox'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{entry}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), entry => $self->make_kvl($args,($args->{'init'}||$args->{'entry'})), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $text : 0); } #: password boxes aren't supported by gdialog sub password { carp("Password entry fields are not supported by GDialog."); return(1); #: Cancel every time. } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text box sub msgbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--scrolltext'); if ($args->{'infobox'}) { $fmt = $self->append_format($fmt,'--infobox'); } else { $fmt = $self->append_format($fmt,'--msgbox'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); $self->_post($args); return($rv == 0 ? 1 : 0); } sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'infobox',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: File box sub textbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--textbox'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'path'}||'.')), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a simple menu list sub menu { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} ||= $args->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--menu'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a check list sub checklist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} = $args->{'menuheight'} if exists $args->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output'); $args->{radiolist} ||= 0; if ($args->{radiolist}) { $fmt = $self->append_format($fmt,'--radiolist'); } else { $fmt = $self->append_format($fmt,'--checklist'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), listheight => $self->make_kvl($args,$args->{'listheight'}) ); if ($args->{radiolist}) { my ($rv,$selected) = $self->command_string($command); return($rv == 0 ? $selected : 0); } my ($rv,$selected) = $self->command_array($command); return($rv == 0 ? @{$selected} : 0); } #: a radio button list sub radiolist { my $self = shift(); return($self->checklist('caller',((caller(1))[3]||'main'),@_,'radiolist',1)); } 1; PK ! �� ��b �b Dialog/Backend/XDialog.podnu ��6�$ =head1 NAME UI::Dialog::Backend::XDialog - backend for the Xdialog(1) =head1 SYNOPSIS use UI::Dialog::Backend::XDialog; my $d = new UI::Dialog::Backend::XDialog ( backtitle => 'Demo', title => 'Default', height => 20, width=>65, listheight => 5 ); $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Backend::XDialog is the UI::Dialog backend for the Xdialog(1) application. While this module is used through UI::Dialog or any other meta module only the compatible methods are ever accessible. However, when using this module directly in your application (as in the SYNOPSIS example) you are given access to all the options and features of the real Xdialog(1) application. =head1 DESCRIPTION This backend is a wrapper for the Xdialog(1) application and as such attempts to extend every facet of Xdialog(1) to you the Perl programmer. The best reference for finding out about the various widgets, please read the fine Xdialog(1) manual as it's got the definitive details on the Xdialog application itself. This perldoc simply briefly describes all the supported options and widgets. Note that XDialog supports newlines (\n) within it's message text area, UI::Dialog strips the newlines in order to not break all the other backends. If you're using XDialog specifically, you can set the B<literal> option to 1 and the message text will be left as it was literally given. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5 ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::XDialog class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<literal = 0,1> (0) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<wmclass = "name"> ('') * =item B<rc-file = "/path/to/any/gtkrc"> ('') * =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<allowclose = 0,1> (0) * =item B<noclose = 0,1> (0) * =item B<screencenter = 0,1> (0) * =item B<undermouse = 0,1> (0) * =item B<autoplacement = 0,1> (0) * =item B<center = 0,1> (0) * =item B<right = 0,1> (0) * =item B<left = 0,1> (0) * =item B<fill = 0,1> (0) * =item B<nowrap = 0,1> (0) * =item B<wrap = 0,1> (0) * =item B<crwrap = 0,1> (0) * =item B<nocrwrap = 0,1> (0) * =item B<buttonsstyle = default,icon,text> (default) * =item B<fixedfont = 0,1> (0) * =item B<editable = 0,1> (0) * =item B<timestamp = 0,1> (0) * =item B<datestamp = 0,1> (0) * =item B<reverse = 0,1> (0) * =item B<keepcolors = 0,1> (0) * =item B<interval = \d+> (0) * =item B<notags = 0,1> (0) * =item B<itemhelp = 0,1> (0) * =item B<defaultitem = "tag"> ('') * =item B<icon = "/path/to/file.xpm"> ('') * =item B<nook = 0,1> (0) * =item B<nocancel = 0,1> (0) * =item B<nobuttons = 0,1> (0) * =item B<defaultno = 0,1> (0) * =item B<wizard = 0,1> (0) * =item B<help = "help"> ('') * =item B<print = "lp0"> ('') * =item B<check = "label"> ('') * =item B<oklabel = "label"> ('') * =item B<cancellabel = "label"> ('') * =item B<beepbin = "/usr/bin/beep"> ('/usr/bin/beep') * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =item B<begin = [ $y, $x ]> (0) * =item B<ignoreeof = 0,1> (0) * =item B<smooth = 0,1> (0) * =item B<height = \d+> (20) * =item B<width = \d+> (65) * =item B<listheight = \d+> (5) * =item B<percentage = \d+> (0) =back =back =head1 WIDGET METHODS =head2 yesno( ) =over 6 =item EXAMPLE if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =over 6 =item DESCRIPTION Present the end user with a message box that has two buttons, yes and no. =back =over 6 =item RETURNS TRUE (1) for a response of YES or FALSE (0) for anything else. =back =head2 msgbox( ) =over 6 =item EXAMPLE $d->msgbox( text => 'A simple message' ); =back =over 6 =item DESCRIPTION Pesent the end user with a message box that has an OK button. =back =over 6 =item RETURNS TRUE (1) for a response of OK or FALSE (0) for anything else. =back =head2 infobox( ) =over 6 =item EXAMPLE $d->infobox( text => 'Information to convey.', timeout => 5000 ); =back =over 6 =item DESCRIPTION Present the end user with a message box that disappears after a certain length of time. The 'timeout' argument is representative of milliseconds. The default timeout is 5000 milliseconds (5 seconds). Yes this message will self destruct! You can also use the alternate timeout option of 'wait' in which is interpreted in seconds instead of milliseconds =back =over 6 =item RETURNS TRUE (1) for a response of OK / normal timeout or FALSE (0) for anything else. =back =head2 gauge_start( ) progress_start( ) =over 4 =item EXAMPLE =over 6 $d->gauge_start( text => 'gauge...', percentage => 1 ); $d->progress_start( text => 'progres...', percentage => 1 ); =back =item DESCRIPTION =over 6 Display a meter bar to the user. This get's the widget realized but requires the use of the other gauge_*() methods for functionality. There are two such meter bars provided by Xdialog(1) and both are handled independantly of each other. This allows for an interesting situation... two progress meters up at the same time, both fully functional. # # Progressive Duality :) # $d->gauge_start( text => 'gauge...', begin => [ 10, 10 ] ); $d->progress_start( text => 'progres...' ); foreach my $i (10,20,30,40,50,60,70,80,90,100) { $d->gauge_set($i); sleep(1); $d->progress_set($i); sleep(1); } $d->gauge_stop(); $d->progress_stop(); =back =item RETURNS =over 6 TRUE (1) if the widget loaded fine and FALSE (0) for anything else. =back =back =head2 gauge_inc( ) progress_inc( ) =over 4 =item EXAMPLE =over 6 $d->gauge_inc( 1 ); $d->progress_inc( 1 ); =back =item DESCRIPTION =over 6 Increment the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_dec( ) progress_dec( ) =over 4 =item EXAMPLE =over 6 $d->gauge_dec( 1 ); $d->progress_dec( 1 ); =back =item DESCRIPTION =over 6 Decrement the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget decremented fine and FALSE (0) for anything else. =back =back =head2 gauge_set( ) progress_set( ) =over 4 =item EXAMPLE =over 6 $d->gauge_set( 99 ); $d->progress_inc( 99 ); =back =item DESCRIPTION =over 6 Set the meter bar to the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_text( ) =over 4 =item EXAMPLE =over 6 $d->gauge_text( 'string' ); =back =item DESCRIPTION =over 6 Set the meter bar message to the given string. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_stop( ) progress_stop( ) =over 4 =item EXAMPLE =over 6 $d->gauge_stop(); $d->progress_stop(); =back =item DESCRIPTION =over 6 End the meter bar widget process. =back =item RETURNS =over 6 TRUE (1) if the widget closed fine and FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some (hidden) text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field that doesn't reveal the input (except to the script) and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 passwords2( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->passwords2( text => 'Enter some (hidden) text.', label1 => 'first field label', label2 => 'second field label' ); =back =item DESCRIPTION =over 6 Present the end user with two (labeled) password input fields. =back =item RETURNS =over 6 an ARRAY of up to two elements if the response is OK and FALSE (0) for anything else. =back =back =head2 passwords3( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->passwords3( text => 'Enter some (hidden) text.', label1 => 'first field label', label2 => 'second field label', label3 => 'third field label' ); =back =item DESCRIPTION =over 6 Present the end user with three (labeled) passsword input fields. =back =item RETURNS =over 6 an ARRAY of up to three elements if the response is OK and FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Enter some text...', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 inputsbox2( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->inputsbox2( text => 'Enter some text.', label1 => 'first field label', input1 => '1st input field', label2 => 'second field label', input2 => '2nd input field' ); =back =item DESCRIPTION =over 6 Present the end user with two (labeled) text input fields. =back =item RETURNS =over 6 an ARRAY of up to two elements if the response is OK and FALSE (0) for anything else. =back =back =head2 inputsbox3( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->inputsbox3( text => 'Enter some text.', label1 => 'first field label', input1 => '1st input field', label2 => 'second field label', input2 => '2nd input field', label3 => 'third field label', input3 => '3rd input field' ); =back =item DESCRIPTION =over 6 Present the end user with three (labeled) text input fields. =back =item RETURNS =over 6 an ARRAY of up to three elements if the response is OK and FALSE (0) for anything else. =back =back =head2 combobox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->combobox( text => 'Enter some text.', editable => 1, list => [ 'item1', 'item2' ] ); =back =item DESCRIPTION =over 6 Present the end user with a (possibly editable) dropdown list. =back =item RETURNS =over 6 a SCALAR or TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 rangebox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->rangebox( text => 'Pick a number...', min => 0, max => 100, def => 50 ); =back =item DESCRIPTION =over 6 Present the end user with a range slider and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 rangesbox2( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->rangesbox2( text => 'Pick a number...', label1 => 'first slider label', min1 => 0, max1 => 100, def1 => 50, label2 => 'second slider label', min1 => 0, max2 => 10, def2 => 5 ); =back =item DESCRIPTION =over 6 Present the end user with two (labeled) text range fields. =back =item RETURNS =over 6 an ARRAY of up to two elements if the response is OK and FALSE (0) for anything else. =back =back =head2 rangesbox3( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->rangesbox3( text => 'Pick a number...', label1 => 'first slider label', min1 => 10, max1 => 100, def1 => 50, label2 => 'second slider label', min2 => 1, max2 => 10, def2 => 5, label3 => 'third slider label', min3 => 2, max3 => 7, def3 => 5 ); =back =item DESCRIPTION =over 6 Present the end user with three (labeled) range sliders. =back =item RETURNS =over 6 an ARRAY of up to three elements if the response is OK and FALSE (0) for anything else. =back =back =head2 spinbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->spinbox( text => 'Pick a number...', min => 0, max => 100, def => 50 ); =back =item DESCRIPTION =over 6 Present the end user with a spin slider and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 spinsbox2( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->spinsbox2( text => 'Pick a number...', label1 => 'first slider label', min1 => 0, max1 => 100, def1 => 50, label2 => 'second slider label', min1 => 0, max2 => 10, def2 => 5 ); =back =item DESCRIPTION =over 6 Present the end user with two (labeled) text spin fields. =back =item RETURNS =over 6 an ARRAY of up to two elements if the response is OK and FALSE (0) for anything else. =back =back =head2 spinsbox3( ) =over 4 =item EXAMPLE =over 6 my @strings = $d->spinsbox3( text => 'Pick a number...', label1 => 'first slider label', min1 => 10, max1 => 100, def1 => 50, label2 => 'second slider label', min2 => 1, max2 => 10, def2 => 5, label3 => 'third slider label', min3 => 25, max3 => 75, def3 => 50 ); =back =item DESCRIPTION =over 6 Present the end user with three (labeled) spin sliders. =back =item RETURNS =over 6 an ARRAY of up to three elements if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 editbox( ) =over 4 =item EXAMPLE =over 6 my $text = $d->editbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with an editable scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 a multiline SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 tailbox( ) =over 4 =item EXAMPLE =over 6 $d->tailbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a scrolling box containing the contents of the given text file. The contents of the window is constantly updated in a similar manner to that of the unix tail(1) command. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 logbox( ) =over 4 =item EXAMPLE =over 6 $d->logbox( path => '/path/to/a/text/file', timestamp => 1, datestamp => 1, reverse => 0 ); =back =item DESCRIPTION =over 6 Present the end user with a scrolling box containing the contents of the given text file. The contents of the window is constantly updated in a similar manner to that of the unix tail(1) command. In addition, this widget can also colourize the output based on any ASCII colour escape sequences found within the file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); my $selection2 = $d->menu( text => 'Select one:', itemhelp => 1, list => [ 'tag1', 'item1', 'help1', 'tag2', 'item2', 'help2', 'tag3', 'item3', 'help3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list and optional help tips. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection1 = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); my @selection2 = $d->checklist( text => 'Select one:', itemhelp => 1, list => [ 'tag1', [ 'item1', 0, 'help1' ], 'tag2', [ 'item2', 1, 'help2' ], 'tag3', [ 'item3', 1, 'help3' ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist and optional help tips. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); my $selection2 = $d->radiolist( text => 'Select one:', itemhelp => 1, list => [ 'tag1', [ 'item1', 0, 'help1' ], 'tag2', [ 'item2', 1, 'help2' ], 'tag3', [ 'item3', 0, 'help3' ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist and optional help tips. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 buildlist( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->buildlist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); my $selection2 = $d->buildlist( text => 'Select one:', itemhelp => 1, list => [ 'tag1', [ 'item1', 0, 'help1' ], 'tag2', [ 'item2', 1, 'help2' ], 'tag3', [ 'item3', 0, 'help3' ] ] ); =back =item DESCRIPTION =over 6 Present the user with a buildable list and optional help tips. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 treeview( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->treeview( text => 'Select one:', list => [ 'tag1', [ 'item1', 0, 1 ], 'tag2', [ 'item2', 1, 2 ], 'tag3', [ 'item3', 0, 2 ] ] ); my $selection2 = $d->treeview( text => 'Select one:', itemhelp => 1, list => [ 'tag1', [ 'item1',0,1,'help1' ], 'tag2', [ 'item2',1,2,'help2' ], 'tag3', [ 'item3',0,2,'help3' ] ] ); =back =item DESCRIPTION =over 6 Present the user with a treeview of items and optional help tips. The treeview list is made up of an array(ref) consisting of a name (which is returned upon user selection) and an array reference containg the details of the item. The details array is made up of a description string, a status indicator (1,0), the desired tree depth and the optional help string. [ 'ReturnName', [ 'Description of item', $status, $depth, 'help string is ignored unless itemhelp is non-null.' ] } =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 calendar( ) =over 4 =item EXAMPLE =over 6 my $date = $d->calendar( text => 'Pick a date...', day => 1, month => 1, year => 1970 ); my ($m,$d,$y) = split(/\//,$date); =back =item DESCRIPTION =over 6 Present the user with a calendar widget preset with the given date. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 timebox( ) =over 4 =item EXAMPLE =over 6 my $time = $d->timebox( text => 'What time?' ); my ($h,$m,$s) = split(/\:/,$time); =back =item DESCRIPTION =over 6 Present the user with a time widget preset with the current time. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::GNOME UI::Dialog::Backend UI::Dialog::Backend::Nautilus UI::Dialog::Backend::XOSD =back =over 2 =item MAN FILES Xdialog(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! ��� j� j� Dialog/Backend/ASCII.pmnu ��6�$ package UI::Dialog::Backend::ASCII; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use UI::Dialog::Backend; use Time::HiRes qw( sleep ); BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } $| = 1; # turn on autoflush #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_state'} = {}; $self->{'_opts'} = {}; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'callbacks'} = $cfg->{'callbacks'} || undef(); $self->{'_opts'}->{'timeout'} = $cfg->{'timeout'} || 0; $self->{'_opts'}->{'wait'} = $cfg->{'wait'} || 0; $self->{'_opts'}->{'debug'} = $cfg->{'debug'} || undef(); $self->{'_opts'}->{'title'} = $cfg->{'title'} || undef(); $self->{'_opts'}->{'backtitle'} = $cfg->{'backtitle'} || undef(); $self->{'_opts'}->{'usestderr'} = $cfg->{'usestderr'} || 0; $self->{'_opts'}->{'extra-button'} = $cfg->{'extra-button'} || 0; $self->{'_opts'}->{'extra-label'} = $cfg->{'extra-label'} || undef(); $self->{'_opts'}->{'help-button'} = $cfg->{'help-button'} || 0; $self->{'_opts'}->{'help-label'} = $cfg->{'help-label'} || undef(); $self->{'_opts'}->{'nocancel'} = $cfg->{'nocancel'} || 0; $self->{'_opts'}->{'maxinput'} = $cfg->{'maxinput'} || 0; $self->{'_opts'}->{'defaultno'} = $cfg->{'defaultno'} || 0; $self->{'_opts'}->{'autoclear'} = $cfg->{'autoclear'} || 0; $self->{'_opts'}->{'clearbefore'} = $cfg->{'clearbefore'} || 0; $self->{'_opts'}->{'clearafter'} = $cfg->{'clearafter'} || 0; $self->{'_opts'}->{'beepbin'} = $cfg->{'beepbin'} || $self->_find_bin('beep') || '/usr/bin/beep'; $self->{'_opts'}->{'beepbefore'} = $cfg->{'beepbefore'} || 0; $self->{'_opts'}->{'beepafter'} = $cfg->{'beepafter'} || 0; $self->{'_opts'}->{'pager'} = ( $cfg->{'pager'} || $self->_find_bin('pager') || $self->_find_bin('less') || $self->_find_bin('more') ); $self->{'_opts'}->{'stty'} = $cfg->{'stty'} || $self->_find_bin('stty'); $self->{'_opts'}->{'trust-input'} = ( exists $cfg->{'trust-input'} && $cfg->{'trust-input'}==1 ) ? 1 : 0; $self->{'_state'} = {'rv'=>0}; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Iherited Overrides #: sub _organize_text { my $self = shift(); my $text = shift() || return(); my @array; if (ref($text) eq "ARRAY") { push(@array,@{$text}); } elsif ($text =~ /\\n/) { @array = split(/\\n/,$text); } else { @array = split(/\n/,$text); } $text = undef(); $text = join("\n",@array); return($self->_strip_text($text)); } sub _merge_attrs { my $self = shift(); my $args = (@_ % 2) ? { @_, '_odd' } : { @_ }; my $defs = $self->{'_opts'}; foreach my $def (keys(%$defs)) { $args->{$def} = $defs->{$def} unless $args->{$def}; } # alias 'filename' and 'file' to path $args->{'path'} = (($args->{'filename'}) ? $args->{'filename'} : ($args->{'file'}) ? $args->{'file'} : ($args->{'path'}) ? $args->{'path'} : ""); $args->{'clear'} = $args->{'clearbefore'} || $args->{'clearafter'} || $args->{'autoclear'} || 0; $args->{'beep'} = $args->{'beepbefore'} || $args->{'beepafter'} || $args->{'autobeep'} || 0; return($args); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: #: this is the dynamic 'Colon Command Help' sub _WRITE_HELP_TEXT { my $self = shift(); my ($head,$foot); my $body = " Colon Commands: [':?' (This help message)], [':pg <N>' (Go to page 'N')], [':n'|':next' (Go to the next page)], [':p'|':prev' (Go to the previous page)], [':esc'|':escape' (Send the [Esc] signal)]. "; # $head .= ("~" x 79); if ($self->{'_opts'}->{'extra-button'} || $self->{'_opts'}->{'extra-label'}) { $foot .= "[':e'|':extra' (Send the [Extra] signal)]\n"; } if (!$self->{'_opts'}->{'nocancel'}) { $foot .= "[':c'|':cancel' (Send the [Cancel] signal)]\n"; } if ($self->{'_opts'}->{'help-button'} || $self->{'_opts'}->{'help-label'}) { $foot .= "[':h'|':help' (Send the [Help] signal)]\n"; } # $foot .= ("~" x 79)."\n"; # $self->msgbox(title=>'Colon Command Help',text=>$head.$body.$foot); $self->msgbox(title=>'Colon Command Help',text=>$body.$foot); } #: this returns the labels (or ' ') for the "extra", "help" and #: "cancel" buttons. sub _BUTTONS { my $self = shift(); my $cfg = $self->_merge_attrs(@_); my ($help,$cancel,$extra) = (' ',' ',' '); $extra = "Extra" if $cfg->{'extra-button'}; $extra = $cfg->{'extra-label'} if $cfg->{'extra-label'}; $extra = "':e'=[".$extra."]" if $extra and $extra ne ' '; $help = "Help" if $cfg->{'help-button'}; $help = $self->{'help-label'} if $cfg->{'help-label'}; $help = "':h'=[".$help."]" if $help and $help ne ' '; $cancel = "Cancel" unless $cfg->{'nocancel'}; $cancel = $cfg->{'cancellabel'} if $cfg->{'cancellabel'}; $cancel = "':c'=[".$cancel."]" if $cancel and $cancel ne ' '; return($help,$cancel,$extra); } #: this writes a standard ascii interface to STDOUT. This is intended for use #: with any non-list native ascii mode widgets. sub _WRITE_TEXT { my $self = shift(); my $cfg = $self->_merge_attrs(@_); my $text = ""; if ($cfg->{'literal'}) { $text = $cfg->{'text'} || ''; } else { $text = $self->_organize_text($cfg->{'text'}) || ""; } $self->clean_format($cfg->{'trust-input'},\$text); my $backtitle = $cfg->{'backtitle'} || " "; my $title = $cfg->{'title'} || " "; format ASCIIPGTXT = +-----------------------------------------------------------------------------+ | @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | $backtitle +-----------------------------------------------------------------------------+ | | | +-------------------------------------------------------------------------+ | | | @|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| | | $title | +-------------------------------------------------------------------------+ | | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | +-------------------------------------------------------------------------+ | | | +-----------------------------------------------------------------------------+ . no strict 'subs'; my $_fh = select(); select(STDERR) unless not $cfg->{'usestderr'}; my $LFMT = $~; $~ = ASCIIPGTXT; write(); $~= $LFMT; select($_fh) unless not $cfg->{'usestderr'}; use strict 'subs'; } #: very much like _WRITE_TEXT() except that this is specifically for #: the menu() widget only. sub _WRITE_MENU { my $self = shift(); my $cfg = $self->_merge_attrs(@_); my $text = ""; if ($cfg->{'literal'}) { $text = $cfg->{'text'} || ''; } else { $text = $self->_organize_text($cfg->{'text'}) || ""; } $self->clean_format($cfg->{'trust-input'},\$text); my $backtitle = $cfg->{'backtitle'} || " "; my $title = $cfg->{'title'} || " "; my $menu = $cfg->{'menu'} || []; my ($help,$cancel,$extra) = $self->_BUTTONS(@_); for (my $i=0;$i<@{$menu};$i++) { $self->clean_format($cfg->{'trust-input'},\$menu->[$i]); } format ASCIIPGMNU = +-----------------------------------------------------------------------------+ | @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | $backtitle +-----------------------------------------------------------------------------+ | | | +-------------------------------------------------------------------------+ | | | @|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| | | $title | +-------------------------------------------------------------------------+ | | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | +-------------------------------------------------------------------------+ | | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[0]||' '),($menu->[1]||' '),($menu->[2]||' '),($menu->[3]||' '),($menu->[4]||' '),($menu->[5]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[6]||' '),($menu->[7]||' '),($menu->[8]||' '),($menu->[9]||' '),($menu->[10]||' '),($menu->[11]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[12]||' '),($menu->[13]||' '),($menu->[14]||' '),($menu->[15]||' '),($menu->[16]||' '),($menu->[17]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[18]||' '),($menu->[19]||' '),($menu->[20]||' '),($menu->[21]||' '),($menu->[22]||' '),($menu->[23]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[24]||' '),($menu->[25]||' '),($menu->[26]||' '),($menu->[27]||' '),($menu->[28]||' '),($menu->[29]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[30]||' '),($menu->[31]||' '),($menu->[32]||' '),($menu->[33]||' '),($menu->[34]||' '),($menu->[35]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[36]||' '),($menu->[37]||' '),($menu->[38]||' '),($menu->[39]||' '),($menu->[42]||' '),($menu->[43]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[42]||' '),($menu->[43]||' '),($menu->[44]||' '),($menu->[45]||' '),($menu->[46]||' '),($menu->[47]||' ') | @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<<< @<<<< @<<<<<<<<<<<<<< | ($menu->[48]||' '),($menu->[49]||' '),($menu->[50]||' '),($menu->[51]||' '),($menu->[52]||' '),($menu->[53]||' ') | @|||||||||||||||||||| @||||||||||||||||||| @||||||||||||||||||| | $extra,$cancel,$help | ':?' = [Colon Command Help] | +-----------------------------------------------------------------------------+ . no strict 'subs'; my $_fh = select(); select(STDERR) unless not $cfg->{'usestderr'}; my $LFMT = $~; $~ = ASCIIPGMNU; write(); $~= $LFMT; select($_fh) unless not $cfg->{'usestderr'}; use strict 'subs'; } #: very much like _WRITE_MENU() except that this is specifically for #: the radiolist() and checklist() widgets only. sub _WRITE_LIST { my $self = shift(); my $cfg = $self->_merge_attrs(@_); my $text = ""; if ($cfg->{'literal'}) { $text = $cfg->{'text'} || ''; } else { $text = $self->_organize_text($cfg->{'text'}) || ""; } $self->clean_format($cfg->{'trust-input'},\$text); my $backtitle = $cfg->{'backtitle'} || " "; my $title = $cfg->{'title'} || " "; my $menu = []; push(@{$menu},@{$cfg->{'menu'}}); my ($help,$cancel,$extra) = $self->_BUTTONS(@_); my $m = @{$menu}; if ($cfg->{'wm'}) { for (my $i = 2; $i < $m; $i += 3) { if ($menu->[$i] && $menu->[$i] =~ /on/i) { $menu->[$i] = '->'; } else { $menu->[$i] = ' '; } } } else { my $mark; for (my $i = 2; $i < $m; $i += 3) { if (!$mark && $menu->[$i] && $menu->[$i] =~ /on/i) { $menu->[$i] = '->'; $mark = 1; } else { $menu->[$i] = ' '; } } } format ASCIIPGLST = +-----------------------------------------------------------------------------+ | @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | $backtitle +-----------------------------------------------------------------------------+ | | | +-------------------------------------------------------------------------+ | | | @|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| | | $title | +-------------------------------------------------------------------------+ | | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | | $text | +-------------------------------------------------------------------------+ | |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[2]||' '),($menu->[0]||' '),($menu->[1]||' '), ($menu->[5]||' '),($menu->[3]||' '),($menu->[4]||' '), ($menu->[8]||' '),($menu->[6]||' '),($menu->[7]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[11]||' '),($menu->[9]||' '),($menu->[10]||' '), ($menu->[14]||' '),($menu->[12]||' '),($menu->[13]||' '), ($menu->[17]||' '),($menu->[15]||' '),($menu->[16]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[20]||' '),($menu->[18]||' '),($menu->[19]||' '), ($menu->[23]||' '),($menu->[21]||' '),($menu->[22]||' '), ($menu->[26]||' '),($menu->[24]||' '),($menu->[25]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[29]||' '),($menu->[27]||' '),($menu->[28]||' '), ($menu->[32]||' '),($menu->[30]||' '),($menu->[31]||' '), ($menu->[35]||' '),($menu->[33]||' '),($menu->[34]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[38]||' '),($menu->[36]||' '),($menu->[37]||' '), ($menu->[41]||' '),($menu->[39]||' '),($menu->[40]||' '), ($menu->[44]||' '),($menu->[42]||' '),($menu->[43]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[47]||' '),($menu->[45]||' '),($menu->[46]||' '), ($menu->[50]||' '),($menu->[48]||' '),($menu->[49]||' '), ($menu->[53]||' '),($menu->[51]||' '),($menu->[52]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[56]||' '),($menu->[54]||' '),($menu->[55]||' '), ($menu->[59]||' '),($menu->[57]||' '),($menu->[58]||' '), ($menu->[62]||' '),($menu->[60]||' '),($menu->[61]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[65]||' '),($menu->[63]||' '),($menu->[64]||' '), ($menu->[68]||' '),($menu->[66]||' '),($menu->[67]||' '), ($menu->[71]||' '),($menu->[69]||' '),($menu->[70]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[74]||' '),($menu->[72]||' '),($menu->[73]||' '), ($menu->[77]||' '),($menu->[75]||' '),($menu->[76]||' '), ($menu->[80]||' '),($menu->[78]||' '),($menu->[79]||' ') |@<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<<< @<<@<<<< @<<<<<<<<<<<<<< | ($menu->[83]||' '),($menu->[81]||' '),($menu->[82]||' '), ($menu->[86]||' '),($menu->[84]||' '),($menu->[85]||' '), ($menu->[89]||' '),($menu->[87]||' '),($menu->[88]||' ') | @|||||||||||||||||||| @||||||||||||||||||| @||||||||||||||||||| | $extra,$cancel,$help | ':?' = [Colon Command Help] | +-----------------------------------------------------------------------------+ . no strict 'subs'; my $_fh = select(); select(STDERR) unless not $cfg->{'usestderr'}; my $LFMT = $~; $~ = ASCIIPGLST; write(); $~= $LFMT; select($_fh) unless not $cfg->{'usestderr'}; use strict 'subs'; } sub _PRINT { my $self = shift(); my $stderr = shift(); if ($stderr) { print STDERR @_; } else { print STDOUT @_; } } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Ask a binary question (Yes/No) sub yesno { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my ($YN,$RESP) = ('Yes|no','YES_OR_NO'); $YN = "yes|No" if $self->{'defaultno'}; while ($RESP !~ /^(y|yes|n|no)$/i) { $self->_clear($args->{'clear'}); $self->_WRITE_TEXT(@_,text=>$args->{'text'}); $self->_PRINT($args->{'usestderr'},"(".$YN."): "); chomp($RESP = <STDIN>); if (!$RESP && $args->{'defaultno'}) { $RESP = "no"; } elsif (!$RESP && !$args->{'defaultno'}) { $RESP = "yes"; } if ($RESP =~ /^(y|yes)$/i) { $self->ra("YES"); $self->rs("YES"); $self->rv('null'); } else { $self->ra("NO"); $self->rs("NO"); $self->rv(1); } } $self->_post($args); return(1) if $self->state() eq "OK"; return(0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text entry sub inputbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $length = $args->{'maxinput'} + 1; my $text = $args->{'text'}; my $string; chomp($text); while ($length > $args->{'maxinput'}) { $self->_clear($args->{'clear'}); $self->_WRITE_TEXT(@_,'text'=>$args->{'text'}); $self->_PRINT($args->{'usestderr'},"input: "); chomp($string = <STDIN>); if ($args->{'maxinput'}) { $length = length($string); } else { $length = 0; } if ($length > $args->{'maxinput'}) { $self->_PRINT($args->{'usestderr'},"error: too many charaters input,". " the maximum is: ".$args->{'maxinput'}."\n"); } } $self->rv('null'); $self->ra($string); $self->rs($string); $self->_post($args); return($string); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Password entry sub password { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); croak("The UI::Dialog::Backend::ASCII password widget depends on the stty ". "binary. This was not found or is not executable.") unless -x $args->{'stty'}; my ($length,$key) = ($args->{'maxinput'} + 1,''); my $string; my $text = $args->{'text'}; chomp($text); my $ENV_PATH = $ENV{'PATH'}; $ENV{'PATH'} = ""; while ($length > $args->{'maxinput'}) { $self->_clear($args->{'clear'}); $self->_WRITE_TEXT(@_,'text'=>$args->{'text'}); $self->_PRINT($args->{'usestderr'},"input: "); if ($self->_is_bsd()) { system "$args->{'stty'} cbreak </dev/tty >/dev/tty 2>&1"; } else { system $args->{'stty'}, '-icanon', 'eol', "\001"; } while ($key = getc(STDIN)) { last if $key =~ /\n/; if ($key =~ /^\x1b$/) { #this could be the DELETE key (not BS or ^H) # ^[[3~ or \x1b\x5b\x33\x7e (aka: ESC + [ + 3 + ~) my $key2 = getc(STDIN); if ($key2 =~ /^\x5b$/) { my $key3 = getc(STDIN); if ($key3 =~ /^\x33$/) { my $key4 = getc(STDIN); if ($key4 =~ /^\x7e$/) { chop($string); # go back five spaces and print five spaces (erase ^[[3~) # go back five spaces again (backtrack), # go back one space, print a space and go back (erase *) if ($args->{'usestderr'}) { print STDERR "\b\b\b\b\b"." "."\b\b\b\b\b"."\b \b"; } else { print STDOUT "\b\b\b\b\b"." "."\b\b\b\b\b"."\b \b"; } } else { $key = $key.$key2.$key3.$key4; } } else { $key = $key.$key2.$key3; } } else { $key = $key.$key2; } } elsif ($key =~ /^(?:\x08|\x7f)$/) { # this is either a BS or ^H chop($string); # go back two spaces and print two spaces (erase ^H) # go back two spaces again (backtrack), # go back one space, print a space and go back (erase *) if ($args->{'usestderr'}) { print STDERR "\b\b"." "."\b\b"."\b \b"; } else { print STDOUT "\b\b"." "."\b\b"."\b \b"; } } else { if ($args->{'usestderr'}) { print STDERR "\b*"; } else { print STDOUT "\b*"; } $string .= $key; } } if ($self->_is_bsd()) { system "$args->{'stty'} -cbreak </dev/tty >/dev/tty 2>&1"; } else { system $args->{'stty'}, 'icanon', 'eol', '^@'; } if ($args->{'maxinput'}) { $length = length($string); } else { $length = 0; } if ($length > $args->{'maxinput'}) { $self->_PRINT($args->{'usestderr'},"error: too many charaters input,". " the maximum is: ".$args->{'maxinput'}."\n"); } } $ENV{'PATH'} = $ENV_PATH; $self->rv('null'); $self->ra($string); $self->rs($string); $self->_post($args); return($string); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Information box sub infobox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->_WRITE_TEXT(@_,'text'=>$args->{'text'}); $self->_PRINT($args->{'usestderr'}); my $s = int(($args->{'wait'}) ? $args->{'wait'} : ($args->{'timeout'}) ? ($args->{'timeout'} / 1000.0) : 1.0); sleep($s); $self->rv('null'); $self->ra('null'); $self->rs('null'); $self->_post($args); return(1); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Message box sub msgbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->_WRITE_TEXT(@_,'text'=>$args->{'text'}); $self->_PRINT($args->{'usestderr'},(" " x 25)."[ Press Enter to Continue ]"); my $junk = <STDIN>; $self->rv('null'); $self->ra('null'); $self->rs('null'); $self->_post($args); return(1); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text box sub textbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $rv = 0; if (-r $args->{'path'}) { my $ENV_PATH = $ENV{'PATH'}; $ENV{'PATH'} = ""; if ($ENV{'PAGER'} && -x $ENV{'PAGER'}) { system($ENV{'PAGER'}." ".$args->{'path'}); $rv = $? >> 8; } elsif (-x $args->{'pager'}) { system($args->{'pager'}." ".$args->{'path'}); $rv = $? >> 8; } else { open(ATBFILE,"<".$args->{'path'}); local $/; my $data = <ATBFILE>; close(ATBFILE); $self->_PRINT($args->{'usestderr'},$data); } $ENV{'PATH'} = $ENV_PATH; } else { return($self->msgbox('title'=>'error','text'=>$args->{'path'}.' is not a readable text file.')); } $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); $self->_post($args); return($rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: A simple menu sub menu { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'menu'} ||= ref($args->{'list'}) ? $args->{'list'} : [$args->{'list'}]; $args->{'menu'} ||= []; my $string; my $rs = ''; my $m = 0; $m = @{$args->{'menu'}}; my ($valid,$menu,$realm) = ([],[],[]); push(@{$menu},@{$args->{'menu'}}) if ref($args->{'menu'}) eq "ARRAY"; for (my $i = 0; $i < $m; $i += 2) { push(@{$valid},$menu->[$i]); } if (@{$menu} >= 60) { my $c = 0; while (@{$menu}) { $realm->[$c] = []; for (my $i = 0; $i < 60; $i++) { push(@{$realm->[$c]},shift(@{$menu})); } $c++; } } else { $realm->[0] = []; push(@{$realm->[0]},@{$menu}); } my $pg = 1; while (!$rs) { $self->_WRITE_MENU(@_,'text'=>$args->{'text'}, 'menu'=>$realm->[($pg - 1||0)]); $self->_PRINT($args->{'usestderr'},"(".$pg."/".@{$realm}."): "); chomp($rs = <STDIN>); if ($rs =~ /^:\?$/i) { $self->_clear($args->{'clear'}); $self->_WRITE_HELP_TEXT(); undef($rs); next; } elsif ($rs =~ /^:(esc|escape)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(255); return(0); } elsif (($args->{'extra-button'} || $args->{'extra-label'}) && $rs =~ /^:(e|extra)$/i) { $self->rv(3); return('EXTRA'); } elsif ($args->{'help-button'} && $rs =~ /^:(h|help)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(2); return($self->state()); } elsif (!$args->{'nocancel'} && $rs =~ /^:(c|cancel)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(1); return($self->state()); } elsif ($rs =~ /^:pg\s*(\d+)$/i) { my $p = $1; if ($p <= @{$realm} && $p > 0) { $pg = $p; } undef($rs); } elsif ($rs =~ /^:(n|next)$/i) { if ($pg < @{$realm}) { $pg++; } else { $pg = 1; } undef($rs); } elsif ($rs =~ /^:(p|prev)$/i) { if ($pg > 1) { $pg--; } else { $pg = @{$realm}; } undef($rs); } else { if (@_ = grep { /^\Q$rs\E$/i } @{$valid}) { $rs = $_[0]; } else { undef($rs); } } $self->_clear($args->{'clear'}); } $self->rv('null'); $self->ra($rs); $self->rs($rs); $self->_post($args); return($rs); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: A multi-selectable list sub checklist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $menulist = ($args->{'menu'} || $args->{'list'}); my $menufix = []; if (ref($menulist) eq "ARRAY") { #: flatten our multidimensional array foreach my $item (@$menulist) { if (ref($item) eq "ARRAY") { pop(@{$item}) if @$item == 3; push(@$menufix,@{$item}); } else { push(@$menufix,$item); } } } $args->{'menu'} = $menufix; my $ra = []; my $rs = ''; my $m; $m = @{$args->{'menu'}} if ref($args->{'menu'}) eq "ARRAY"; my ($valid,$menu,$realm) = ([],[],[]); push(@{$menu},@{$args->{'menu'}}) if ref($args->{'menu'}) eq "ARRAY"; for (my $i = 0; $i < $m; $i += 3) { push(@{$valid},$menu->[$i]); } if (@{$menu} >= 90) { my $c = 0; while (@{$menu}) { $realm->[$c] = []; for (my $i = 0; $i < 90; $i++) { push(@{$realm->[$c]},shift(@{$menu})); } $c++; } } else { $realm->[0] = []; push(@{$realm->[0]},@{$menu}); } my $go = "GO"; my $pg = 1; while ($go) { $self->_WRITE_LIST(@_,'wm'=>'check','text'=>$args->{'text'},'menu'=>$realm->[($pg - 1||0)]); $self->_PRINT($args->{'usestderr'},"(".$pg."/".@{$realm}."): "); chomp($rs = <STDIN>); if ($rs =~ /^:\?$/i) { $self->_clear($args->{'clear'}); $self->_WRITE_HELP_TEXT(); undef($rs); next; } elsif ($rs =~ /^:(esc|escape)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(255); return($self->state()); } elsif (($args->{'extra-button'} || $args->{'extra-label'}) && $rs =~ /^:(e|extra)$/i) { $self->_clear($args->{'clear'}); $self->rv(3); return($self->state()); } elsif (($args->{'help-button'} || $args->{'help-label'}) && $rs =~ /^:(h|help)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(2); return($self->rv()); } elsif (!$args->{'nocancel'} && $rs =~ /^:(c|cancel)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(1); return($self->state()); } elsif ($rs =~ /^:pg\s*(\d+)$/i) { my $p = $1; if ($p <= @{$realm} && $p > 0) { $pg = $p; } } elsif ($rs =~ /^:(n|next)$/i) { if ($pg < @{$realm}) { $pg++; } else { $pg = 1; } } elsif ($rs =~ /^:(p|prev)$/i) { if ($pg > 1) { $pg--; } else { $pg = @{$realm}; } } else { my @opts = split(/\,\s|\,|\s/,$rs); my @good; foreach my $opt (@opts) { if (@_ = grep { /^\Q$opt\E$/i } @{$valid}) { push(@good,$_[0]); } } if (@opts == @good) { undef($go); $ra = []; push(@{$ra},@good); } } $self->_clear($args->{'clear'}); undef($rs); } $self->rv('null'); $self->ra($ra); $self->rs(join("\n",@$ra)); $self->_post($args); return(@{$ra}); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: A radio button based list. very much like the menu widget. sub radiolist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $menulist = ($args->{'menu'} || $args->{'list'}); my $menufix = []; if (ref($menulist) eq "ARRAY") { #: flatten our multidimensional array foreach my $item (@$menulist) { if (ref($item) eq "ARRAY") { pop(@{$item}) if @$item == 3; push(@$menufix,@{$item}); } else { push(@$menufix,$item); } } } $args->{'menu'} = $menufix; my $rs = ''; my $m; $m = @{$args->{'menu'}} if ref($args->{'menu'}) eq "ARRAY"; my ($valid,$menu,$realm) = ([],[],[]); push(@{$menu},@{$args->{'menu'}}) if ref($args->{'menu'}) eq "ARRAY"; for (my $i = 0; $i < $m; $i += 3) { push(@{$valid},$menu->[$i]); } if (@{$menu} >= 90) { my $c = 0; while (@{$menu}) { $realm->[$c] = []; for (my $i = 0; $i < 90; $i++) { push(@{$realm->[$c]},shift(@{$menu})); } $c++; } } else { $realm->[0] = []; push(@{$realm->[0]},@{$menu}); } my $pg = 1; while (!$rs) { $self->_WRITE_LIST(@_,'text'=>$args->{'text'},'menu'=>$realm->[($pg - 1||0)]); $self->_PRINT($args->{'usestderr'},"(".$pg."/".@{$realm}."): "); chomp($rs = <STDIN>); if ($rs =~ /^:\?$/i) { $self->_clear($args->{'clear'}); $self->_WRITE_HELP_TEXT(); undef($rs); next; } elsif ($rs =~ /^:(esc|escape)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(255); return($self->rv()); } elsif (($args->{'extra-button'} || $args->{'extra-label'}) && $rs =~ /^:(e|extra)$/i) { $self->rv(3); return($self->state()); } elsif (($args->{'help-button'} || $args->{'help-label'}) && $rs =~ /^:(h|help)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(2); return($self->state()); } elsif (!$args->{'nocancel'} && $rs =~ /^:(c|cancel)$/i) { $self->_clear($args->{'clear'}); undef($rs); $self->rv(1); return($self->state()); } elsif ($rs =~ /^:pg\s*(\d+)$/i) { my $p = $1; if ($p <= @{$realm} && $p > 0) { $pg = $p; } undef($rs); } elsif ($rs =~ /^:(n|next)$/i) { if ($pg < @{$realm}) { $pg++; } else { $pg = 1; } undef($rs); } elsif ($rs =~ /^:(p|prev)$/i) { if ($pg > 1) { $pg--; } else { $pg = @{$realm}; } undef($rs); } else { if (@_ = grep { /^\Q$rs\E$/i } @{$valid}) { $rs = $_[0]; } else { undef($rs); } } $self->_clear($args->{'clear'}); } $self->rv('null'); $self->ra($rs); $self->rs($rs); $self->_post($args); return($rs); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Simple ASCII progress indicator :) sub spinner { my $self = shift(); if (!$self->{'__SPIN'} || $self->{'__SPIN'} == 1) { $self->{'__SPIN'} = 2; return("\b|"); } elsif ($self->{'__SPIN'} == 2) { $self->{'__SPIN'} = 3; return("\b/"); } elsif ($self->{'__SPIN'} == 3) { $self->{'__SPIN'} = 4; return("\b-"); } elsif ($self->{'__SPIN'} == 4) { $self->{'__SPIN'} = 1; return("\b\\"); } } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Simple ASCII meter bar # the idea of a "true" dialog like gauge widget with ASCII is not that bad and # as such, I've named these methods differently so as to keep the namespace # open for gauge_*() widgets. sub draw_gauge { my $self = shift(); my $args = $self->_merge_attrs(@_); my $length = $args->{'length'} || $args->{'width'} || 74; my $bar = ($args->{'bar'} || "-") x $length; my $current = $args->{'current'} || 0; my $total = $args->{'total'} || 0; my $percent = (($current && $total) ? int($current / ($total / 100)) : ($args->{'percent'} || '0')); $percent = int(($percent <= 100 && $percent >= 0) ? $percent : 0 ); my $perc = int((($length / 100) * $percent)); substr($bar,($perc||0),1,($args->{'mark'}||"|")); my $text = (($percent =~ /^\d$/) ? " " : ($percent =~ /^\d\d$/) ? " " : "").$percent."% ".$bar; $self->_PRINT($args->{'usestderr'},(($args->{'noCR'} && not $args->{'CR'}) ? "" : "\x0D").$text); return($percent||1); } sub end_gauge { my $self = shift(); my $args = $self->_merge_attrs(@_); $self->_PRINT($args->{'usestderr'},"\n"); } 1; PK ! S�+�M& M& Dialog/Backend/GDialog.podnu ��6�$ =head1 NAME UI::Dialog::Backend::GDialog - backend for the antiquated GNOME dialog variant. =head1 SYNOPSIS use UI::Dialog::Backend::GDialog; my $d = new UI::Dialog::Backend::GDialog ( backtitle => 'Demo', title => 'Default' ); $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Backend::GDialog is the UI::Dialog backend for the antiquated GNOME dialog variant. While this module is used through UI::Dialog or any other loader module only the compatible methods are ever accessible. However, when using this module directly in your application (as in the SYNOPSIS example) you are given access to all the options and features of the real gdialog(1) application. =head1 DESCRIPTION GDialog is being phased out by the much more satisfying Zenity, but we support it's usage via this backend anyways! =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5 ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::GDialog class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<literal = 0,1> (0) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<height = \d+> (0) * =item B<width = \d+> (0) * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =back =back =head1 WIDGET METHODS =head2 yesno( ) =over 4 =item EXAMPLE =over 6 if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, yes and no. =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 infobox( ) =over 4 =item EXAMPLE =over 6 $d->infobox( text => 'A simple 6 second message.', timeout => 6000 ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box for a limited duration of time. The timeout is specified in thousandths of a second, ie: 1000 = 1 second. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some (hidden) text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field that doesn't reveal the input (except to the script) and a message. GDialog does not actually support a (hidden input text field) inputbox other than the plain one. UI::Dialog::Backend::GDialog instead warns the user that their password will be visible and presents them with a plain inputbox. Future versions of this module will use gnome-ssh-askpass or x11-ssh-askpass instead of the plain text widget. The end user will be notified that the ssh-askpass program is going to ask them for their password instead of the regular inputbox(). The lack of a proper password box for gdialog is my first reason for being thankful that zenity(1) is so 'now' and gdialog is being left back in 'then'! =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Please enter some text...', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 gauge_start( ) =over 4 =item EXAMPLE =over 6 $d->gauge_start( text => 'gauge...', percentage => 1 ); =back =item DESCRIPTION =over 6 Display a meter bar to the user. This get's the widget realized but requires the use of the other gauge_*() methods for functionality. =back =item RETURNS =over 6 TRUE (1) if the widget loaded fine and FALSE (0) for anything else. =back =back =head2 gauge_inc( ) =over 4 =item EXAMPLE =over 6 $d->gauge_inc( 1 ); =back =item DESCRIPTION =over 6 Increment the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_set( ) =over 4 =item EXAMPLE =over 6 $d->gauge_set( 99 ); =back =item DESCRIPTION =over 6 Set the meter bar to the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_end( ) =over 4 =item EXAMPLE =over 6 $d->gauge_end(); =back =item DESCRIPTION =over 6 End the meter bar widget process. One of the flaws with gdialog is that the gauge widget does not close properly and requies the end user to close the gauge window when 100% has been reached. This is the second reason why I'm glad gdialog is going the way of the dodo. =back =item RETURNS =over 6 TRUE (1) if the widget closed fine and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::GNOME UI::Dialog::Backend UI::Dialog::Backend::Nautilus UI::Dialog::Backend::XOSD =back =over 2 =item MAN FILES gdialog(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! �z�� � Dialog/Backend/KDialog.podnu ��6�$ =head1 NAME UI::Dialog::Backend::KDialog - backend for the KDE dialog variant. =head1 SYNOPSIS use UI::Dialog::Backend::KDialog; my $d = new UI::Dialog::Backend::KDialog ( backtitle => 'Demo', title => 'Default' ); $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Backend::KDialog is the UI::Dialog backend for the KDE dialog variant. While this module is used through UI::Dialog or any other loader module only the compatible methods are ever accessible. However, when using this module directly in your application (as in the SYNOPSIS example) you are given access to all the options and features of the real kdialog(1) application. =head1 DESCRIPTION Although this dialog variant doesn't have any progress meters, it does have the benefits of many different file/uri/directory widgets. It's a shame that this is the only dialog variant for KDE. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5 ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::KDialog class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<literal = 0,1> (0) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<nocancel = 0,1> (0) * =item B<defaultno = 0,1> (0) * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =item B<extrabutton = 0,1> (0) * =item B<extralabel = "extra label"> (0) * =item B<helpbutton = 0,1> (0) * =item B<helplabel = "help label"> (0) * =item B<maxinput = \d+> (0) * =back =back =head1 WIDGET METHODS =head2 yesno( ) yesnocancel( ) warningyesno( ) warningyesnocancel( ) =over 4 =item EXAMPLE =over 6 # if ($d->warningyesnocancel( text => 'A question?') ) { # if ($d->warningyesno( text => 'A question?') ) { # if ($d->yesnocancel( text => 'A question?') ) { if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, yes and no. =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some (hidden) text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field that doesn't reveal the input (except to the script) and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Enter some text.', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) getopenfilename( ) getsavefilename( ) getopenurl( ) getsaveurl( ) =over 4 =item EXAMPLE =over 6 # my $text = $d->getsaveurl( path => '/path/' ); # my $text = $d->getopenurl( path => '/path/' ); # my $text = $d->getsavefilename( path => '/path/' ); # my $text = $d->getopenfilename( path => '/path/' ); my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) getexistingdirectory( ) =over 4 =item EXAMPLE =over 6 # my $text = $d->getexistingdirectory( path => '/path/to/a/dir' ); my $text = $d->dselect( path => '/path/to/a/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::KDE UI::Dialog::Backend UI::Dialog::Backend::XOSD =back =over 2 =item MAN FILES None. Use `kdialog --help` from a command line. =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! `c�`% `% Dialog/Backend/ASCII.podnu ��6�$ =head1 NAME UI::Dialog::Backend::ASCII - Dialog backend for the native Perl mode of basic text. =head1 SYNOPSIS use UI::Dialog::Backend::ASCII; my $d = new UI::Dialog::Backend::ASCII ( backtitle => 'Demo', title => 'Default' ); $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Backend::ASCII is the UI::Dialog backend for the native Perl mode of basic text. The widgets are very much "rigid" in that the width and height arguments are completely ignored. =head1 DESCRIPTION This backend is intended as a last resort mechanism in that no other dialog variant has been found and so this, the most absolute of bargain basement dialog variant interfaces, is used instead. =head1 EXPORT =over 2 =item None =back =head1 INHERITS =over 2 =item UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new UI::Dialog::Backend::ASCII ( title => 'Default Title', backtitle => 'Backtitle' ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::ASCII class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. =over 6 =item B<debug = 0,1,2> (0) =item B<literal = 0,1> (0) =item B<backtitle = "backtitle"> ('') =item B<title = "title"> ('') =item B<nocancel = 0,1> (0) =item B<defaultno = 0,1> (0) =item B<beepbefore = 0,1> (0) =item B<beepafter = 0,1> (0) =item B<extra-button = 0,1> (0) =item B<extra-label = "extra label"> (0) =item B<help-button = 0,1> (0) =item B<help-label = "help label"> (0) =item B<maxinput = \d+> (0) =item B<autoclear = 0,1> (0) =item B<pager = "/usr/bin/pager"> ('/usr/bin/pager') =item B<stty = "/usr/bin/stty"> ('/usr/bin/stty') =back =back =head1 WIDGET METHODS =head2 yesno( ) =over 4 =item EXAMPLE =over 6 if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, yes and no. =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 infobox( ) =over 4 =item EXAMPLE =over 6 $d->infobox( text => 'A simple 6 second message.', timeout => 6000 ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box for a limited duration of time. The timeout is specified in thousandths of a second, ie: 1000 = 1 second. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some (hidden) text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field that doesn't reveal the input (except to the script) and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Please enter some text...', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 spinner( ) =over 4 =item EXAMPLE =over 6 print STDOUT "spinner... "; for (20,40,60,80,100) { print $d->spinner(); sleep(1); } print STDOUT "\bdone.\n"; =back =item DESCRIPTION =over 6 Return the next character in the spin sequence prefixed with a backspace (\b) character. The spinner is made up of four ASCII characters; | (pipe), \ (back slash), / (forward slash), - (hyphen). The complete sequence is as follows: | / - \ | / - \ =back =item RETURNS =over 6 A two character SCALAR. =back =back =head2 draw_gauge( ) =over 4 =item EXAMPLE =over 6 foreach my $i (20,40,60,80,100) { last unless $d->draw_gauge( bar => "-", mark => "|", length => 74, percent => $i ); sleep(1); } foreach my $i (200,500,10000,12000,12345) { last unless $d->draw_gauge( bar => "-", mark => "|", length => 74, current => $i, total => 12345 ); sleep(1); } =back =item DESCRIPTION =over 6 Draw a meter bar with a position indicator. You can specify alternate characters for use as the meter bar itself (default is "-") and the positional marker (default to "|") as well as an arbitrary length to the bar itself. There are two different ways to present the bar, either by specifying the percentage to display or by specifying the current and total values and and the widget will figure out the percentage for you. =back =item RETURNS =over 6 None. =back =back =head2 end_gauge( ) =over 4 =item EXAMPLE =over 6 $d->end_gauge(); =back =item DESCRIPTION =over 6 Simply print a newline for use when the finished with the draw_gauge() widget as that leaves the cursor at the end of the last line of output. =back =item RETURNS =over 6 None. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Backend UI::Dialog::Console =back =over 2 =item MAN FILES pager(1), less(1), more(1), stty(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! i�Gk% k% Dialog/Backend/Whiptail.podnu ��6�$ =head1 NAME UI::Dialog::Backend::Whiptail - Backend for the Whiptail dialog variant =head1 SYNOPSIS use UI::Dialog::Backend::Whiptail; my $d = new UI::Dialog::Backend::Whiptail ( backtitle => 'Demo', title => 'Default' ); $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog::Backend::Whiptail is the UI::Dialog backend for the Whiptail dialog variant. While this module is used through UI::Dialog or any other loader module only the compatible methods are ever accessible. However, when using this module directly in your application (as in the SYNOPSIS example) you are given access to all the options and features of the real whiptail(1) application. =head1 DESCRIPTION This dialog variant is the staple of the Debian console apt/dpkg interface. There isn't very much interesting about this particular backend. This is very much a basic dialog variant in comparison to things like Xdialog and cDialog. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 UI::Dialog::Backend =back =head1 CONSTRUCTOR =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5 ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Backend::Whiptail class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<literal = 0,1> (0) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<height = \d+> (0) * =item B<listheight = \d+> (5) * =item B<width = \d+> (0) * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =back =back =head1 WIDGET METHODS =head2 yesno( ) =over 4 =item EXAMPLE =over 6 if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, yes and no. =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 infobox( ) =over 4 =item EXAMPLE =over 6 $d->infobox( text => 'A simple 6 second message.', timeout => 6000 ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box for a limited duration of time. The timeout is specified in thousandths of a second, ie: 1000 = 1 second. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some (hidden) text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field that doesn't reveal the input (except to the script) and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Enter some text.', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head2 gauge_start( ) =over 4 =item EXAMPLE =over 6 $d->gauge_start( text => 'gauge...', percentage => 1 ); =back =item DESCRIPTION =over 6 Display a meter bar to the user. This get's the widget realized but requires the use of the other gauge_*() methods for functionality. =back =item RETURNS =over 6 TRUE (1) if the widget loaded fine and FALSE (0) for anything else. =back =back =head2 gauge_inc( ) =over 4 =item EXAMPLE =over 6 $d->gauge_inc( 1 ); =back =item DESCRIPTION =over 6 Increment the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_dec( ) =over 4 =item EXAMPLE =over 6 $d->gauge_dec( 1 ); =back =item DESCRIPTION =over 6 Decrement the meter by the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget incremented fine and FALSE (0) for anything else. =back =back =head2 gauge_set( ) =over 4 =item EXAMPLE =over 6 $d->gauge_set( 99 ); =back =item DESCRIPTION =over 6 Set the meter bar to the given amount. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_text( ) =over 4 =item EXAMPLE =over 6 $d->gauge_text( 'string' ); =back =item DESCRIPTION =over 6 Set the meter bar message to the given string. =back =item RETURNS =over 6 TRUE (1) if the widget set fine and FALSE (0) for anything else. =back =back =head2 gauge_stop( ) =over 4 =item EXAMPLE =over 6 $d->gauge_stop(); =back =item DESCRIPTION =over 6 End the meter bar widget process. =back =item RETURNS =over 6 TRUE (1) if the widget closed fine and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::Console UI::Dialog::Backend =back =over 2 =item MAN FILES whiptail(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! 8ߌ/�; �; Dialog/Backend/Whiptail.pmnu ��6�$ package UI::Dialog::Backend::Whiptail; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use FileHandle; use Time::HiRes qw( sleep ); use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = {}; bless($self, $class); $self->{'_state'} = {}; $self->{'_opts'} = {}; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $self->{'_opts'}->{'literal'} = $cfg->{'literal'} || 0; $self->{'_opts'}->{'callbacks'} = $cfg->{'callbacks'} || undef(); $self->{'_opts'}->{'debug'} = $cfg->{'debug'} || undef(); $self->{'_opts'}->{'title'} = $cfg->{'title'} || undef(); $self->{'_opts'}->{'backtitle'} = $cfg->{'backtitle'} || undef(); $self->{'_opts'}->{'width'} = $cfg->{'width'} || 65; $self->{'_opts'}->{'height'} = $cfg->{'height'} || 10; $self->{'_opts'}->{'listheight'} = $cfg->{'listheight'} || $cfg->{'menuheight'} || 10; $self->{'_opts'}->{'percentage'} = $cfg->{'percentage'} || 1; $self->{'_opts'}->{'bin'} ||= $self->_find_bin('whiptail'); $self->{'_opts'}->{'autoclear'} = $cfg->{'autoclear'} || 0; $self->{'_opts'}->{'clearbefore'} = $cfg->{'clearbefore'} || 0; $self->{'_opts'}->{'clearafter'} = $cfg->{'clearafter'} || 0; $self->{'_opts'}->{'beepbin'} = $cfg->{'beepbin'} || $self->_find_bin('beep') || '/usr/bin/beep'; $self->{'_opts'}->{'beepbefore'} = $cfg->{'beepbefore'} || 0; $self->{'_opts'}->{'beepafter'} = $cfg->{'beepafter'} || 0; $self->{'_opts'}->{'timeout'} = $cfg->{'timeout'} || 0; $self->{'_opts'}->{'wait'} = $cfg->{'wait'} || 0; unless (-x $self->{'_opts'}->{'bin'}) { croak("the whiptail binary could not be found at: ".$self->{'_opts'}->{'bin'}); } $self->{'_opts'}->{'trust-input'} = $cfg->{'trust-input'} || 0; $self->{'test_mode'} = $cfg->{'test_mode'} if exists $cfg->{'test_mode'}; $self->{'test_mode_result'} = ''; return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: my $SIG_CODE = {}; sub _del_gauge { my $CODE = $SIG_CODE->{$$}; unless (not ref($CODE)) { delete($CODE->{'_GAUGE'}); $CODE->rv('1'); $CODE->rs('null'); $CODE->ra('null'); $SIG_CODE->{$$} = ""; } } sub append_format_base { my ($self,$args,$fmt) = @_; $fmt = $self->append_format_check($args,$fmt,'backtitle','--backtitle {{backtitle}}'); $fmt = $self->append_format_check($args,$fmt,"defaultno","--defaultno"); $fmt = $self->append_format_check($args,$fmt,"default-item","--default-item {{default-item}}"); $fmt = $self->append_format_check($args,$fmt,"fullbuttons","--fullbuttons"); $fmt = $self->append_format_check($args,$fmt,"nocancel","--nocancel"); $fmt = $self->append_format_check($args,$fmt,"yes-button","--yes-button {{yes-button}}"); $fmt = $self->append_format_check($args,$fmt,"no-button","--no-button {{no-button}}"); $fmt = $self->append_format_check($args,$fmt,"ok-button","--ok-button {{ok-button}}"); $fmt = $self->append_format_check($args,$fmt,"cancel-button","--cancel-button {{cancel-button}}"); $fmt = $self->append_format_check($args,$fmt,"notags","--notags"); $fmt = $self->append_format_check($args,$fmt,"scrolltext","--scrolltext"); $fmt = $self->append_format_check($args,$fmt,"top-left","--top-left"); if ($self->{'_opts'}->{'force-no-separate-output'}) { delete $args->{'separate-output'}; } else { $fmt = $self->append_format_check($args,$fmt,"separate-output","--separate-output"); } return $fmt; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Ask a binary question (Yes/No) sub yesno { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--yesno {{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my $rv = $self->command_state($command); if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $self->rv($rv); } else { $self->ra("YES"); $self->rs("YES"); $self->rv('null'); } $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text entry sub inputbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); if ($args->{'password'}) { $fmt = $self->append_format($fmt,'--passwordbox'); } else { $fmt = $self->append_format($fmt,'--inputbox'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{entry}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), entry => $self->make_kvl($args,($args->{'init'}||$args->{'entry'})), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $text : 0); } #: password boxes aren't supported by gdialog sub password { my $self = shift(); return($self->inputbox('caller',((caller(1))[3]||'main'),@_,'password',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Text box sub msgbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'msgbox'} ||= 'msgbox'; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); if ($args->{'infobox'}) { $fmt = $self->append_format($fmt,'--infobox'); } else { $fmt = $self->append_format($fmt,'--msgbox'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); $args->{'timeout'} ||= $args->{'wait'} if exists $args->{'wait'} and $args->{'wait'}; my $tmp_term = $ENV{TERM}; $ENV{TERM} = 'vt220' # wow, really folks? if ($args->{'infobox'}); my $rv = $self->command_state($command); if ($args->{'infobox'}) { $ENV{TERM} = $tmp_term; # yep, really. my $sec = 0; if ($args->{'timeout'}) { $sec = int($args->{'timeout'} ? ($args->{'timeout'} / 1000.0) : 1.0); $self->_debug("Will sleep for timeout=".$sec); } elsif ($args->{'wait'}) { $sec = int($args->{'wait'} ? $args->{'wait'} : 1); $self->_debug("Will sleep for wait=".$sec); } sleep($sec) if $sec; } $self->_post($args); return($rv == 0 ? 1 : 0); } sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'infobox',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: File box sub textbox { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--textbox'); $fmt = $self->append_format($fmt,'{{path}} {{height}} {{width}}'); my $command = $self->prepare_command ( $args, $fmt, path => $self->make_kvl($args,($args->{'path'}||'.')), ); my ($rv,$text) = $self->command_string($command); $self->_post($args); return($rv == 0 ? 1 : 0); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: Lists sub menu { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} = $args->{'menuheight'} if exists $args->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output'); $fmt = $self->append_format($fmt,'--menu'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); my ($rv,$selected) = $self->command_string($command); $self->_post($args); return($rv == 0 ? $selected : 0); } sub checklist { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $args->{'listheight'} = $args->{'menuheight'} if exists $args->{'menuheight'}; my $fmt = $self->prepare_format($args); $fmt = $self->append_format_base($args,$fmt); $fmt = $self->append_format($fmt,'--separate-output'); $args->{radiolist} ||= 0; if ($args->{radiolist}) { $fmt = $self->append_format($fmt,'--radiolist'); } else { $fmt = $self->append_format($fmt,'--checklist'); } $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{listheight}} {{list}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), ); if ($args->{radiolist}) { my ($rv,$selected) = $self->command_string($command); return($rv == 0 ? $selected : 0); } my ($rv,$selected) = $self->command_array($command); return($rv == 0 ? @{$selected} : 0); } sub radiolist { my $self = shift(); return($self->checklist('caller',((caller(1))[3]||'main'),@_,'radiolist',1)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: progress meter sub gauge_start { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->{'_GAUGE'} ||= {}; $self->{'_GAUGE'}->{'ARGS'} = $args; if (defined $self->{'_GAUGE'}->{'FH'}) { $self->rv(129); $self->_post($args); return(0); } my $fmt = $self->prepare_format($args); $fmt = $self->append_format($fmt,'--gauge'); $fmt = $self->append_format($fmt,'{{text}} {{height}} {{width}} {{percentage}}'); my $command = $self->prepare_command ( $args, $fmt, text => $self->make_kvt($args,$args->{'text'}), percentage => $self->make_kvl($args,$args->{'percentage'}||'0'), ); $self->{'_GAUGE'}->{'PERCENT'} = ($args->{'percentage'} || '0'); $self->{'_GAUGE'}->{'FH'} = new FileHandle; $self->{'_GAUGE'}->{'FH'}->open("| $command"); my $rv = $? >> 8; $self->{'_GAUGE'}->{'FH'}->autoflush(1); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } return($this_rv); } sub gauge_inc { my $self = $_[0]; my $incr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} += $incr; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_dec { my $self = $_[0]; my $decr = $_[1] || 1; return(0) unless defined $self->{'_GAUGE'}->{'FH'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} -= $decr; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_set { my $self = $_[0]; my $perc = $_[1] || $self->{'_GAUGE'}->{'PERCENT'} || 1; my $fh = $self->{'_GAUGE'}->{'FH'}; return(0) unless $self->{'_GAUGE'}->{'FH'}; $self->{'_GAUGE'}->{'PERCENT'} = $perc; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh $self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_text { my $self = $_[0]; my $mesg = $_[1] || return(0); my $fh = $self->{'_GAUGE'}->{'FH'}; return(0) unless $self->{'_GAUGE'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; print $fh "\nXXX\n\n".$mesg."\n\nXXX\n\n".$self->{'_GAUGE'}->{'PERCENT'}."\n"; return(((defined $self->{'_GAUGE'}->{'FH'}) ? 1 : 0)); } sub gauge_stop { my $self = $_[0]; return(0) unless $self->{'_GAUGE'}->{'FH'}; my $args = $self->{'_GAUGE'}->{'ARGS'}; my $fh = $self->{'_GAUGE'}->{'FH'}; $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; $self->{'_GAUGE'}->{'FH'}->close(); delete($self->{'_GAUGE'}->{'FH'}); delete($self->{'_GAUGE'}->{'ARGS'}); delete($self->{'_GAUGE'}->{'PERCENT'}); delete($self->{'_GAUGE'}); $self->rv('null'); $self->rs('null'); $self->ra('null'); $self->_post($args); return(1); } 1; PK ! �Q�� # # Dialog/Screen/Menu.podnu ��6�$ =head1 NAME UI::Dialog::Screen::Menu - wrapper to screen dialogs. =head1 SYNOPSIS use UI::Dialog::Screen::Menu; # $d is an existing instance of UI::Dialog my $screen = new UI::Dialog::Screen::Menu ( dialog => $d ); $screen->add_menu_item("This is the label", sub { print "Hello\n"; }); # $rv is 0 if the user canceled, 1 if any menu item was selected. my $rv = $screen->run(); =head1 ABSTRACT UI::Dialog::Screen::Menu is a helper class which enables a clean and modular code flow for menu driven applications using UI::Dialog. Using callbacks assigned to menu items, a reactionary model to scripting with UI::Dialog becomes rapidly easy. =head1 DESCRIPTION UI::Dialog::Screen::Menu is actually "external" to the UI::Dialog core usage. The class simply wraps around an existing UI::Dialog instance for rendering a menu-driven flow of screens. Using this class, you define a number of screen instances and assign callbacks to each of the menu items. Once defined, simply call B<run()> (or B<loop()> to execute B<run()> indefinitely). When a user selects one of the menu items, the assigned function will be executed. From within those functions, simply call other UI::Dialog::Screen::Menu instances and that's how you branch your user's experience from one screen to the next. See the B<EXAMPLES> =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 None =back =head1 CONSTRUCTOR =head2 new( %options ) =over 4 =item EXAMPLE =over 6 # Have UI::Dialog::Screen::Menu use an existing UI::Dialog instance # to render the user interface. my $s = new( dialog => $d ); # Also accepts UI::Dialog constructor arguments, so that it can create # it's own instance of UI::Dialog if none is provided. my $s = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'zenity', 'xdialog', 'gdialog' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Screen::Menu class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<dialog = UI::Dialog> (undef) =item B<debug = 0,1,2> (0) =item B<order = [ zenity, xdialog, gdialog, kdialog, cdialog, whiptail, ascii ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =item B<height = \d+> (20) * =item B<width = \d+> (65) * =item B<listheight = \d+> (5) * =back =back =head1 STATE METHODS =head2 run( ) =over 4 =item EXAMPLE =over 6 my $rv = $s->run(); =back =item DESCRIPTION =over 6 Render the screen menu immediately. This method blocks until the user input has been received and acted upon. =back =item RETURNS =over 6 TRUE if the user selected an item from the menu, FALSE otherwise. =back =back =head2 loop( ) =over 4 =item EXAMPLE =over 6 $s->loop(); =back =item DESCRIPTION =over 6 Calls the B<run()> method immediately. Once B<run()> completes it's execution, the B<loop()> decides whether or not to display again. If the return value of run() is TRUE, the B<loop()> will continue. If the use pressed Cancel (or Escape) or any other action other than one of the menu items; the B<loop()> will end. The B<loop()> will also end if the B<break_loop()> method is called. =back =item RETURNS =over 6 TRUE if the user selected an item from the menu, FALSE otherwise. =back =back =head2 is_looping( ) =over 4 =item EXAMPLE =over 6 if ($s->is_looping()) { print "Currently in a UI::Dialog::Screen::Menu loop\n"; } =back =item DESCRIPTION =over 6 Returns TRUE if the given screen is in a menu B<loop()>, FALSE otherwise. =back =item RETURNS =over 6 a single SCALAR. =back =back =head2 break_loop( ) =over 4 =item EXAMPLE =over 6 $s->break_loop(); =back =item DESCRIPTION =over 6 Flags the screen menu to stop looping. This does not close or otherwise clear the screen. This simply flags the loop to exit at the end of it's current run. =back =item RETURNS =over 6 None. =back =back =head1 SCREEN METHODS =head2 add_menu_item( ) =over 4 =item EXAMPLE =over 6 my $index = $s->add_menu_item( "Menu Item Label", \%some_function ); =back =item DESCRIPTION =over 6 Append a new item to the menu list. =back =item RETURNS =over 6 Returns the list index (starting from 0) of the item that was just appended to the list. =back =back =head2 get_menu_items( ) =over 4 =item EXAMPLE =over 6 my @items = $s->get_menu_items(); =back =item DESCRIPTION =over 6 Returns an array of hashrefs. Each hash contains a "label" and "func" key/value pairs. =back =item RETURNS =over 6 An ARRAY. =back =back =head2 del_menu_item( ) =over 4 =item EXAMPLE =over 6 my $old_item = $d->del_menu_item( $index ); =back =item DESCRIPTION =over 6 Remove a specific item from the menu, addressed by it's list index (starting from 0), and return the menu item as a hashref. =back =item RETURNS =over 6 A HASH containing the 'label' and 'func' of the menu item that was just removed from the menu list. =back =back =head2 set_menu_item( ) =over 4 =item EXAMPLE =over 6 # Modify the 'label' and 'func' for a specific menu item my $original_item = $s->set_menu_item( $index, $label, $func ); # Modify just the label of a menu item my $original_item = $s->set_menu_item( $index, $label, undef ); # Modify just the func of a menu item my $original_item = $s->set_menu_item( $index, undef, $func ); # Effectively do nothing my $original_item = $s->set_menu_item( $index, undef, undef ); =back =item DESCRIPTION =over 6 Modify the menu item addressed by the given index (starting from 0). If the 'label' and/or 'func' arguments are undef then the previous value is kept. =back =item RETURNS =over 6 A HASH of the original values for the modified menu item. =back =back =head1 EXAMPLE USAGE The below example assumed that $d is an instances of UI::Dialog. # Create our first screen my $s1 = new UI::Dialog::Screen::Menu ( dialog => $d ); $s1->add_menu_item( "Just an option", \&some_function ); # Add a menu item that updates it's own label every time # it is selected. our $counter = 0; $s1->add_menu_item ( "Counter: ".$counter, sub { my ($self,$dialog,$index) = @_; $counter++; $self->set_menu_item($index,"Counter: ".$counter, undef); } ); # Create a second screen my $s2 = new UI::Dialog::Screen::Menu ( dialog => $d ); $s2->add_menu_item( "Another item", \&another_function ); # Link the second screen to an option of the first $s1->add_menu_item( "Goto Screen 2", sub { $s2->loop(); } ); # Start a menu loop and actually display the first screen $s1->loop(); Users can get to second menu from selecting the third item on the first menu screen. As long as the user continues to select items from the second menu, it will continue to loop. If the user cancels the second screen, the will return to the first which will itself continue to loop. =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::GNOME UI::Dialog::KDE UI::Dialog::Console UI::Dialog::Screen::Druid UI::Dialog::Backend UI::Dialog::Backend::ASCII UI::Dialog::Backend::CDialog UI::Dialog::Backend::GDialog UI::Dialog::Backend::KDialog UI::Dialog::Backend::Nautilus UI::Dialog::Backend::Whiptail UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD UI::Dialog::Backend::Zenity =back =over 2 =item MAN FILES dialog(1), whiptail(1), zenity(1), gdialog(1), Xdialog(1), osd_cat(1), kdialog(1) and nautilus(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! ��Y Y Dialog/Screen/Menu.pmnu ��6�$ package UI::Dialog::Screen::Menu; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use constant { TRUE => 1, FALSE => 0 }; BEGIN { use vars qw($VERSION); $VERSION = '1.21'; } use UI::Dialog; # Example Usage # # my $screen = new UI::Dialog::Screen::Menu ( dialog => $d ); # $screen->add_menu_item( "Label", \&func ); # $screen->loop(); # sub new { my ($class, %args) = @_; $args{__loop_active} = FALSE; unless (exists $args{dialog}) { $args{dialog} = new UI::Dialog ( title => (defined $args{title}) ? $args{title} : '', backtitle => (defined $args{backtitle}) ? $args{backtitle} : '', height => (defined $args{height}) ? $args{height} : 20, width => (defined $args{width}) ? $args{width} : 65, listheight => (defined $args{listheight}) ? $args{listheight} : 5, order => (defined $args{order}) ? $args{order} : undef, PATH => (defined $args{PATH}) ? $args{PATH} : undef, beepbefore => (defined $args{beepbefore}) ? $args{beepbefore} : undef, beepafter => (defined $args{beepafter}) ? $args{beepafter} : undef, 'trust-input' => (defined $args{'trust-input'} && $args{'trust-input'} == 1) ? 1 : 0, ); } unless (exists $args{menu}) { $args{menu} = []; } return bless { %args }, $class; } #: $screen->add_menu_item( "Label", \&func ); #: Add an item to the menu with a label and a callback func # sub add_menu_item { my ($self,$label,$func) = @_; push(@{$self->{menu}},{label=>$label,func=>$func}); return @{$self->{menu}} - 1; } #: @list_of_menu_items = $screen->get_menu_items(); #: Return a list of all the menu items in order. Each item is a hash #: with a label and a func reference. # sub get_menu_items { my ($self) = @_; return @{$self->{menu}}; } #: %item = $screen->del_menu_item( $index ); #: Remove a menu item and return it. The item will no longer show in the #: list of avaliable menu items. # sub del_menu_item { my ($self,$index) = @_; if (defined $index && $index >= 0 && $index < @{$self->{menu}}) { return splice(@{$self->{menu}}, $index, 1); } return undef; } #: $screen->set_menu_item( $index, $label||undef, $func||undef ); #: Update a menu item's properties. If a field is "undef", no action #: is performed on that item's field. Returns the menu_item before #: modification. #: Note: $index starts from 0. # sub set_menu_item { my ($self,$index,$label,$func) = @_; if (defined $index && $index >= 0 && $index < @{$self->{menu}}) { my $item = $self->{menu}->[$index]; my $orig = { label => $item->{label}, func => $item->{func} }; $self->{menu}->[$index]->{label} = $label if defined $label; $self->{menu}->[$index]->{func} = $func if defined $func; return $orig; } return undef; } #: $screen->run(); #: Blocking call, display the menu and react once. Returns 0 if cancelled, #: returns 1 if an item was selected and the function called. # sub run { my ($self) = @_; my @menu_list = (); my $c = 1; foreach my $data (@{$self->{menu}}) { push(@menu_list,$c,$data->{label}); $c++; } my $sel = $self->{dialog}->menu ( title => (defined $self->{title}) ? $self->{title} : '', text => (defined $self->{text}) ? $self->{text} : '', list => \@menu_list ); if ($self->{dialog}->state() eq "OK") { my $data = $self->{menu}->[$sel-1]; my $func = $data->{func}; &{$func}($self,$self->{dialog},$sel-1) if defined $func and ref($func) eq "CODE"; return 1; } else { if (exists $self->{cancel}) { my $func = $self->{cancel}; &{$func}($self,$self->{dialog},-1) if defined $func and ref($func) eq "CODE"; } } return 0; } #: $screen->loop(); #: Blocking call, execute $screen->run() indefinitely. If run() was cancelled, #: the loop will break. sub loop { my ($self) = @_; $self->{__loop_active} = TRUE; while ($self->{__loop_active}) { last unless $self->run(); } } #: $screen->break_loop(); #: Notify loop() to break instead of re-iterate regardless of user input. # sub break_loop { my ($self) = @_; $self->{__loop_active} = FALSE; } #: $screen->is_looping(); #: Returns TRUE if currently looping, FALSE otherwise # sub is_looping { my ($self) = @_; return ($self->{__loop_active}) ? TRUE : FALSE; } 1; # END OF UI::Dialog::Screen::Menu PK ! ��{<m m Dialog/Screen/Druid.podnu ��6�$ =head1 NAME UI::Dialog::Screen::Druid - wrapper to screen dialogs. =head1 SYNOPSIS use UI::Dialog::Screen::Druid; # $d is an existing instance of UI::Dialog my $druid = new UI::Dialog::Screen::Druid ( dialog => $d ); $druid->add_yesno_step('somename',"Ask the user a y/n question?"); $druid->add_input_step ( 'anothertag',"Tell me something:", "Hello World: {{somename}}" ); my (%answers) = $druid->perform(); if ($answers{aborted}) { die "user canceled at step: ".$answers{key}."\n"; } # %answers contains all the responses, keyed by the first argument # used in the add_*_step() methods. print $answers{anothertag}."\n"; =head1 ABSTRACT UI::Dialog::Screen::Druid is a helper class which enables a clean and modular code flow for menu driven applications using UI::Dialog. Using a simple "question" format, tucked into a queue; developers can ask a series of questions and receive back a HASH (or HASHREF) of all the user input keyed by the first argument to the add_*_step() methods. =head1 DESCRIPTION UI::Dialog::Screen::Druid is actually "external" to the UI::Dialog core usage. The class simply wraps around an existing UI::Dialog instance for rendering a druid-walkthrough series of dialogs. Using this class, you define one (or more) druid instances and assign tags and helpful text to questions. Once defined, simply call B<perform()> and receive the resulting HASH (or HASHREF). If the user aborts (presses <ESC>) the druid performance, a simple hash containing two key/value pairs is returned and resembles the following: { aborted => 1, key => "tagNameOfAbortedStep" } =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 None =back =head1 CONSTRUCTOR =head2 new( %options ) =over 4 =item EXAMPLE =over 6 # Have UI::Dialog::Screen::Druid use an existing UI::Dialog instance # to render the user interface. my $druid = new( dialog => $d ); # Also accepts UI::Dialog constructor arguments, so that it can create # it's own instance of UI::Dialog if none is provided. my $druid = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'zenity', 'xdialog', 'gdialog' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog::Screen::Druid class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<dialog = UI::Dialog> (undef) =item B<debug = 0,1,2> (0) =item B<order = [ zenity, xdialog, gdialog, kdialog, cdialog, whiptail, ascii ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =item B<height = \d+> (20) * =item B<width = \d+> (65) * =item B<listheight = \d+> (5) * =back =back =head1 DRUID METHODS =head2 add_yesno_step( ) =over 4 =item EXAMPLE =over 6 $druid->add_yesno_step( "yesnotag", "Yes/no question?" ); =back =item DESCRIPTION =over 6 Append a new B<yesno()> dialog step to the druid performance, keyed by the first argument. =back =item RETURNS =over 6 Nothing =back =back =head2 add_input_step( ) =over 4 =item EXAMPLE =over 6 $druid->add_input_step( "inputtag", "Helpful text", "default text" ); =back =item DESCRIPTION =over 6 Append a new B<inputbox()> dialog step to the druid performance, keyed by the first argument. A unique property to this druid step in particular is that the default text (the third arguement) goes through a semi-templating system. By using B<{{keytag}}> within the default text string, when the input question is posed to the user, the B<{{keytag}}> string is replaced with the user's response to a prior question keyed as B<keytag>. For example: $druid->add_input_step ( "user_name", "Tell me the user name you'd like.", "$ENV{USER}" ); $druid->add_input_step ( "another_q", "What is the email address you'd like?", "{{user_name}}@example.com" ); When the above is performed, assuming the user entered "boring" for the I<user_name> question; the suggested (default) email address would become I<boring@example.com>. =back =item RETURNS =over 6 Nothing =back =back =head2 add_password_step( ) =over 4 =item EXAMPLE =over 6 $druid->add_password_step( "passwordtag", "Helpful text." ); =back =item DESCRIPTION =over 6 Append a new B<password()> dialog step to the druid performance, keyed by the first argument. =back =item RETURNS =over 6 Nothing =back =back =head2 add_menu_step( ) =over 4 =item EXAMPLE =over 6 $druid->add_menu_step( "menutag", "Helpful text", [qw|item0 item1|] ); =back =item DESCRIPTION =over 6 Append a new B<menu()> dialog step to the druid performance, keyed by the first argument. The third argument is an ARRAYREF containing the options the user can select from. This is not the same as the menu() method's B<list> argument. Whatever is supplied is what is returned as the response for the keyed question. In the above B<EXAMPLE> the user would be presented with two options in a menu; "item0" and "item1". Upon selecting one of those two options; the I<%answers> HASH would contain I<menutag => "item0"> (if the user selected "item0" of course). =back =item RETURNS =over 6 Nothing =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog UI::Dialog::GNOME UI::Dialog::KDE UI::Dialog::Console UI::Dialog::Screen::Menu UI::Dialog::Backend UI::Dialog::Backend::ASCII UI::Dialog::Backend::CDialog UI::Dialog::Backend::GDialog UI::Dialog::Backend::KDialog UI::Dialog::Backend::Nautilus UI::Dialog::Backend::Whiptail UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD UI::Dialog::Backend::Zenity =back =over 2 =item MAN FILES dialog(1), whiptail(1), zenity(1), gdialog(1), Xdialog(1), osd_cat(1), kdialog(1) and nautilus(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! �{� � Dialog/Screen/Druid.pmnu ��6�$ package UI::Dialog::Screen::Druid; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use constant { TRUE => 1, FALSE => 0 }; BEGIN { use vars qw($VERSION); $VERSION = '1.21'; } use UI::Dialog; # Example Usage # # my $druid = new UI::Dialog::Screen::Druid # ( dialog => $DIALOG, # title => 'druid walkthrough' # ); # $druid->add_yesno_step('bool0',"Boolean 0"); # $druid->add_yesno_step('bool1',"Boolean 1"); # my (%answers) = $druid->perform(); # sub new { my ($class, %args) = @_; unless (exists $args{dialog}) { $args{dialog} = new UI::Dialog ( title => (defined $args{title}) ? $args{title} : '', backtitle => (defined $args{backtitle}) ? $args{backtitle} : '', height => (defined $args{height}) ? $args{height} : 20, width => (defined $args{width}) ? $args{width} : 65, listheight => (defined $args{listheight}) ? $args{listheight} : 5, order => (defined $args{order}) ? $args{order} : undef, PATH => (defined $args{PATH}) ? $args{PATH} : undef, beepbefore => (defined $args{beepbefore}) ? $args{beepbefore} : undef, beepafter => (defined $args{beepafter}) ? $args{beepafter} : undef, ); } $args{performance} = [] unless exists $args{performance}; return bless { %args }, $class; } #: not used yet, not sure keys being forced unique isn't too rigid # sub __verify_unique_tag { my ($self,$tag) = @_; if (grep {m!^\Q$tag\E$!} keys %{$self->{performance}}) { return FALSE; # exists already, not unique tag } # doesn't exist, is unique tag return TRUE; } #: $druid->add_input_step( "key", "Label text", "Default text"); #: Add a text-input step to the performance # sub add_input_step { my ($self,$tag,$text,$default) = @_; push( @{$self->{performance}}, { type=>"input", tag=>$tag, text=>$text, default=>defined $default ? $default : '', } ); } #: $druid->add_password_step( "key", "Label text" ); #: Add a password step to the performance # sub add_password_step { my ($self,$tag,$text) = @_; push( @{$self->{performance}}, { type=>"password", tag=>$tag, text=>$text } ); } #: $druid->add_menu_step( "key", "Label text", [qw|opt1 opt2 op3|] ); #: Add a menu select step to the performance # sub add_menu_step { my ($self,$tag,$text,$options) = @_; push( @{$self->{performance}}, { type=>"menu", tag=>$tag, text=>$text, options=>$options } ); } #: $druid->add_yesno_step( "key", "Label text" ); #: Add a yesno step to the performance # sub add_yesno_step { my ($self,$tag,$text) = @_; push( @{$self->{performance}}, { type=>"yesno", tag=>$tag, text=>$text } ); } #: my (%answers) = $druid->perform(); #: Show the performance! Walk the user to the druid's step :) # sub perform { my ($self) = @_; my $key = undef; my %answers = (); foreach my $step ( @{$self->{performance}} ) { $key = $step->{tag}; my $r = undef; # yesno questions if ($step->{type} eq "yesno") { $r = $self->{dialog}->yesno ( title => $step->{tag}, text => $step->{text} ); goto PERFORM_STEP_FAILURE if $self->{dialog}->state() eq "ESC"; } # text-input questions elsif ($step->{type} eq "input") { my $default = defined $step->{default} ? $step->{default} : ''; foreach my $key (keys %answers) { my $val = $answers{$key}; if ($default =~ m!\{\{\Q${key}\E\}\}!mg) { $default =~ s!\{\{\Q${key}\E\}\}!${val}!g; } } foreach my $step (@{$self->{performance}}) { if (exists $step->{default}) { my $key = $step->{tag}; my $val = $step->{default}; if ($default =~ m!\{\{\Q${key}\E\}\}!mg) { $default =~ s!\{\{\Q${key}\E\}\}!${val}!g; } } } $r = $self->{dialog}->inputbox ( title => $step->{tag}, text => $step->{text}, entry => $default ); goto PERFORM_STEP_FAILURE if $self->{dialog}->state() ne "OK"; } # password questions elsif ($step->{type} eq "password") { $r = $self->{dialog}->password ( title => $step->{tag}, text => $step->{text} ); goto PERFORM_STEP_FAILURE if $self->{dialog}->state() ne "OK"; } # menu questions elsif ($step->{type} eq "menu") { my @list = (); my $count = 0; foreach (@{$step->{options}}) { $count++; push(@list,$count,$_); } $r = $self->{dialog}->menu ( title => $step->{tag}, text => $step->{text}, list => \@list ); goto PERFORM_STEP_FAILURE if $self->{dialog}->state() ne "OK"; $r = $step->{options}[$r-1]; } $answers{$key} = $r; } return wantarray ? %answers : \%answers; PERFORM_STEP_FAILURE: my %aborted = (aborted=>1,key=>$key); return wantarray ? %aborted : \%aborted; } 1; # END OF UI::Dialog::Screen::Druid PK ! �)��d �d Dialog/Backend.pmnu ��6�$ package UI::Dialog::Backend; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use Cwd qw( abs_path ); use File::Basename; use Text::Wrap qw( wrap ); use String::ShellQuote; use File::Slurp; BEGIN { use vars qw($VERSION); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: #: not even really necessary as this class is inherited, and the constructor is #: more often than not overridden by the backend inheriting it. sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = ((ref($_[0]) eq "HASH") ? $_[0] : (@_) ? { @_ } : {}); my $self = { '_opts' => $cfg }; $self->{'test_mode'} = $cfg->{'test_mode'} if exists $cfg->{'test_mode'}; $self->{'test_mode_result'} = ''; bless($self, $class); return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Accessory Methods #: #: Return the path to the dialog variant binary sub get_bin { return $_[0]->{'_opts'}{'bin'} if defined $_[0]->{'_opts'}{'bin'}; return undef; } #: Provide the API interface to nautilus sub nautilus { my $self = $_[0]; my $nautilus = $self->{'_nautilus'} || {}; unless (ref($nautilus) eq "UI::Dialog::Backend::Nautilus") { if ($self->_find_bin('nautilus')) { if (eval "require UI::Dialog::Backend::Nautilus; 1") { require UI::Dialog::Backend::Nautilus; $self->{'_nautilus'} = new UI::Dialog::Backend::Nautilus; } } } return($self->{'_nautilus'}); } #: Provide the API interface to osd_cat (aka: xosd) sub xosd { my $self = shift(); my @args = (@_ %2 == 0) ? (@_) : (); my $xosd = $self->{'_xosd'} || {}; unless (ref($xosd) eq "UI::Dialog::Backend::XOSD") { if ($self->_find_bin('osd_cat')) { if (eval "require UI::Dialog::Backend::XOSD; 1") { require UI::Dialog::Backend::XOSD; $self->{'_xosd'} = new UI::Dialog::Backend::XOSD (@args); } } } return($self->{'_xosd'}); } #: Provide the API interface to notify-send sub notify_send { my $self = shift(); my @args = (@_ %2 == 0) ? (@_) : (); my $notify_send = $self->{'_notify_send'} || {}; unless (ref($notify_send) eq "UI::Dialog::Backend::NotifySend") { if ($self->_find_bin('notify-send')) { if (eval "require UI::Dialog::Backend::NotifySend; 1") { require UI::Dialog::Backend::NotifySend; $self->{'_notify_send'} = new UI::Dialog::Backend::NotifySend (@args); } } } return($self->{'_notify_send'}); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: State Methods #: #: enable altering of attributes sub attr { my $self = $_[0]; my $name = $_[1]; unless ($_[2]) { return($self->{'_opts'}->{$name}) unless not $self->{'_opts'}->{$name}; return(undef()); } if ($_[2] == 0 || $_[2] =~ /^NULL$/i) { $self->{'_opts'}->{$name} = 0; } else { $self->{'_opts'}->{$name} = $_[2]; } return($self->{'_opts'}->{$name}); } #: return the last response data as an ARRAY sub ra { my $self = shift(); my (@argv) = @_; if (@argv) { if (defined $argv[0] && $argv[0] =~ m!^null$!i) { $self->{'_state'}{'ra'} = []; } else { $self->{'_state'}{'ra'} = \@argv; } } else { $self->{'_state'}->{'ra'} ||= []; } return(@{ $self->{'_state'}->{'ra'} }); } #: return the last response data as a SCALAR sub rs { my $self = shift(); my (@argv) = @_; if (@argv) { if (defined $argv[0] && $argv[0] =~ m!^null$!i) { $self->{'_state'}{'rs'} = ''; } else { $self->{'_state'}{'rs'} = $argv[0]; } } return($self->{'_state'}->{'rs'}); } #: return the last exit code as a SCALAR sub rv { my $self = shift(); my (@argv) = @_; if (@argv) { if (defined $argv[0] && $argv[0] =~ m!^null$!i) { $self->{'_state'}{'rv'} = 0; } else { $self->{'_state'}{'rv'} = $argv[0]; } } return($self->{'_state'}->{'rv'}); } #: report on the state of the last dialog variant execution. sub state { my $self = shift(); my $rv = $self->rv() || 0; $self->_debug((join(" | ",(caller())))." > state() > is: ".($rv||'NULL'),2); if ($rv == 1 or $rv == 129) { return("CANCEL"); } elsif ($rv == 2) { return("HELP"); } elsif ($rv == 3) { return("EXTRA"); } elsif ($rv == 254) { return("ERROR"); } elsif ($rv == 255) { return("ESC"); } elsif (not $rv or $rv =~ /^null$/i) { return("OK"); } else { return("UNKNOWN(".$rv.")"); } } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Preparation Methods # #: construct a HASHREF for command {{tag}} substitutions sub make_kvt { my ($self,$args,$value) = @_; return { literal => ($args->{'literal'} || 0), width => ($args->{'width'}||'65'), trust => ($args->{'trust-input'} || 0), value => ($value || '') }; } sub make_kvl { my ($self,$args,$value) = @_; return { literal => 1, width => ($args->{'width'}||'65'), trust => ($args->{'trust-input'} || 0), value => ($value || '') }; } #: Helper method to generate a base format string, accepts additional #: strings which are considered trusted programmer template input. sub prepare_format { my $self = shift(@_); my $args = shift(@_); # start with our binary path my $fmt = $self->{'_opts'}{'bin'}; $fmt = $self->append_format_check($args,$fmt,'title','--title {{title}}'); return $fmt; } sub append_format { my ($self,$fmt,$value) = @_; if (ref($fmt) eq "SCALAR") { $$fmt .= ' '.$value; } else { $fmt .= ' '.$value; } return $fmt; } #: simple test and if true; append value to format sub append_format_check { my ($self,$args,$fmt,$key,$value) = @_; if (exists $args->{$key} and defined $args->{$key} and $args->{$key}) { $fmt = $self->append_format($fmt,$value); } return $fmt; } sub clean_format { my ($self,$trust,$sref) = @_; unless (ref($sref) eq "SCALAR") { die("Programmer error. clean_format requires a SCALAR ref, found: ".ref($sref)); } $$sref =~ s!\x00!!mg; # remove nulls #unless ($trust) { #$$sref =~ s!\`!'!mg; #$$sref =~ s!\$\(!\(!mg; #$$sref =~ s!\$!\\\$!mg; #} #$$sref =~ s!"!\\"!mg; # escape double-quotes return $sref; } sub trust_quote { my ($self,$kv,$string) = @_; if ($kv->{trust}) { return '"'.$string.'"'; } return shell_quote($string); } #: Given a command string "format" and any key/value replacement pairs, #: construct the exec'able command string. sub prepare_command { my $self = shift(@_); my $args = shift(@_); my $format = shift(@_); my (%rpl_add) = @_; my %rpl = (); foreach my $key (keys %{$args}) { $rpl{$key} = $self->make_kvl($args,$args->{$key}||''); } foreach my $key (keys %rpl_add) { $rpl{$key} = $rpl_add{$key}; } foreach my $key (keys %rpl) { my $value = $rpl{$key}->{value}||''; if (ref($value) eq "ARRAY") { #: menu, checklist, radiolist... my $list = ''; foreach my $item (@{$value}) { if (ref($item) eq "ARRAY") { # checklist, radiolist... if (@{$item} == 2) { $list .= ' '.$self->trust_quote($rpl{$key},$item->[0]); $list .= ' '.($item->[1] ? 'on' : 'off'); next; } elsif (@{$item} == 3) { $list .= ' '.$self->trust_quote($rpl{$key},$item->[0]); $list .= ' '.($item->[1] ? 'on' : 'off'); $list .= ' '.($self->trust_quote($rpl{$key},$item->[2])||1); next; } elsif (@{$item} == 4) { $list .= ' ' . $self->trust_quote($rpl{$key},$item->[0]); $list .= ' '.($item->[1] ? 'on' : 'off'); $list .= ' '.($self->trust_quote($rpl{$key},$item->[2])||1); $list .= ' '.$self->trust_quote($rpl{$key},$item->[3]); next; } } # menu... $list .= ' '.$self->trust_quote($rpl{$key},$item); } $format =~ s!\{\{\Q${key}\E\}\}!${list}!mg; } # if (ref($value) eq "ARRAY") elsif ($key eq "list") { # assume this has been manipulated already? $format =~ s!\{\{\Q${key}\E\}\}!${value}!mg; } else { $value ||= '' unless defined $value; $value = "$1" if $value =~ m!^(\d+)$!; if (ref(\$value) eq "SCALAR") { unless ($rpl{$key}->{'trust'}||$rpl{$key}->{literal}) { $value = $self->_organize_text ( $value, $rpl{$key}->{width}, $rpl{$key}->{'trust'} ); } $value = $self->trust_quote($rpl{$key},$value); $format =~ s!\{\{\Q${key}\E\}\}!${value}!mg; } } } return $format; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Execution Methods #: sub is_unit_test_mode { my ($self) = @_; return 1 if ( exists $self->{'test_mode'} && defined $self->{'test_mode'} && $self->{'test_mode'} ); return 0; } sub get_unit_test_result { my ($self) = @_; return $self->{'test_mode_result'}; } #: run command and return the rv and any text output from stderr sub perform_command { my $self = $_[0]; my $cmnd = $_[1]; if ($self->is_unit_test_mode()) { $self->{'test_mode_result'} = $cmnd; return (0,'test_mode_result'); } $self->_debug("perform_command: ".$cmnd.";"); my $tmp_stderr = $self->gen_tempfile_name(); system($cmnd." 2> ".$tmp_stderr); my $rv = $? >> 8; my $text = read_file($tmp_stderr); unlink($tmp_stderr) if -f $tmp_stderr; $self->_debug("perform_command: stderr=".shell_quote($text),2); return ($rv,$text); } #: execute a simple command (return the exit code only); sub command_state { my $self = $_[0]; my $cmnd = $_[1]; if ($self->is_unit_test_mode()) { $self->{'test_mode_result'} = $cmnd; return 0; } my ($rv,$text) = $self->perform_command($cmnd); $self->_debug("command_state: rv=".$rv,1); $self->rv($rv); $self->rs('null'); $self->ra('null'); return($rv); } #: execute a command and return the exit code and one-line SCALAR sub command_string { my $self = $_[0]; my $cmnd = $_[1]; if ($self->is_unit_test_mode()) { $self->{'test_mode_result'} = $cmnd; return (wantarray) ? (0,'') : ''; } my ($rv,$text) = $self->perform_command($cmnd); chomp($text); $self->_debug("command_string: rv=".$rv.", rs=".shell_quote($text),1); $self->rv($rv); $self->rs($text); $self->ra('null'); return($text) unless defined wantarray; return (wantarray) ? ($rv,$text) : $text; } #: execute a command and return the exit code and ARRAY of data sub command_array { my $self = $_[0]; my $cmnd = $_[1]; if ($self->is_unit_test_mode()) { $self->{'test_mode_result'} = $cmnd; return (wantarray) ? (0,[]) : []; } my ($rv,$text) = $self->perform_command($cmnd); $self->_debug("command_array: rv=".$rv.", rs=".shell_quote($text),1); $self->rv($rv); $self->rs($text); # this is so hackish that it may just work my $alt_text = $text; $alt_text =~ s!\r??\n!__\\n!mg; #: replace newlines with "a symbol" my @alt_items = split(/_\\n/,$alt_text); #: split on "part symbol" my @alt_final = (); foreach my $alt_item (@alt_items) { my $i = $alt_item; $i =~ s!_$!!; #: remove the trailing bit of symbol push(@alt_final,$i); } $self->ra(@alt_final); #: final array can now contain blanks return([$self->ra()]) unless defined wantarray and wantarray; return (wantarray) ? ($rv,[$self->ra()]) : [$self->ra()]; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Utility Methods #: #: make some noise sub beep { my $self = $_[0]; return($self->_beep(1)); } #: Clear terminal screen. sub clear { my $self = $_[0]; return($self->_clear(1)); } # word-wrap a line sub word_wrap { my $self = shift(); my $width = shift() || 65; my $indent = shift() || ""; my $sub_indent = shift() || ""; $Text::Wrap::columns = $width - 3; my $raw = join("\n",@_); my $string = wrap($indent, $sub_indent, $raw); return(split(m!\n!,$string)); } # generate a temporary file name sub gen_tempfile_name { my $self = $_[0]; my $template = $self->{'_opts'}->{'tempfiletemplate'} || "UI_Dialog_tempfile_XXXXX"; if (eval("require File::Temp; 1")) { use File::Temp qw( tempfile ); my ($fh,$filename) = tempfile( UNLINK => 1 ) or croak( "Can't create tempfile: $!" ); if (wantarray) { return($fh,$filename); } else { close($fh); # actually required on win32 return($filename); } return($fh,$filename); } else { my $mktemp = $self->_find_bin('mktemp'); if ($mktemp && -x $mktemp) { chomp(my $tempfile = `$mktemp "$template"`); return($tempfile); } else { #pseudo-random filename coming up! my $tempdir = "/tmp"; unless (-d $tempdir) { if (-d "/var/tmp") { $tempdir = "/var/tmp"; } else { $tempdir = "."; } } $self->gen_random_string(5); my $tempfile = "UI_Dialog_tempfile_".$self->gen_random_string(5); while (-e $tempdir."/".$tempfile) { $self->gen_random_string(5); $tempfile = "UI_Dialog_tempfile_".$self->gen_random_string(5); } return($tempdir."/".$tempfile); } } } # generate a random string as a (possibly) suitable failover option in the # event that File::Temp is not installed and the 'mktemp' program does not # exist in the path. sub gen_random_string { my $self = $_[0]; my $length = $_[1] || 5; my $string = ""; my $counter = 0; while ($counter < $length) { # 33 - 127 my $num = rand(128); while ($num < 33 or $num > 127) { $num = rand(128); } $string .= chr($num); $counter++; } return($string); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Widget Wrapping Methods #: #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: file select sub fselect { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); $self->rv('NULL'); $self->rs('NULL'); $self->ra('NULL'); $self->_beep($args->{'beepbefore'}); my $cwd = abs_path(); $args->{'path'} ||= abs_path(); my $pre_selection = $args->{'path'}; my $path = $args->{'path'}; if (-f $pre_selection) { $path = dirname($path); } if (!$path || $path =~ /^(\.|\.\/)$/) { $path = $cwd; } my $user_selection = $pre_selection; my ($menu,$list) = ([],[]); FSEL: while ($self->state() ne "ESC" && $self->state() ne "CANCEL") { my $entries = ($args->{'dselect'}) ? ['[new directory]'] : ['[new file]']; ($menu, $list) = $self->_list_dir($path, $entries, $args->{'dselect'}); $user_selection = $self->menu ( height=>$args->{'height'}, width=>$args->{'width'}, listheight=>($args->{'listheight'}||$args->{'menuheight'}), title=>$args->{'title'}, backtitle=>$args->{'backtitle'}, text=>"Select a ".($args->{'dselect'}?'path':'file').": ".$path, list=>$menu ); if ($self->state() eq "CANCEL") { $self->rv(1); $self->rs('NULL'); $self->ra('NULL'); last FSEL; } elsif ($user_selection ne "") { if ($list->[($user_selection - 1 || 0)] =~ /^\[(new\sdirectory|new\sfile)\]$/) { my $nfn; while (!$nfn || -e $path."/".$nfn) { $nfn = $self->inputbox ( height=>$args->{'height'}, width=>$args->{'width'}, title=>$args->{'title'}, text=>'Enter a name (will have a base directory of: '.$path.')' ); next FSEL if $self->state() eq "ESC" or $self->state() eq "CANCEL"; if (-e $path."/".$nfn) { $self->msgbox ( title=>'error', text=>$path."/".$nfn.' exists. Choose another name please.'); } } $user_selection = $path."/".$nfn; $user_selection =~ s!/$!! unless $user_selection =~ m!^/$!; $user_selection =~ s!/\./!/!g; $user_selection =~ s!/+!/!g; last FSEL; } elsif ($list->[($user_selection - 1 || 0)] eq "../") { $path = dirname($path); } elsif ($list->[($user_selection - 1 || 0)] eq "./") { $user_selection = $path; $user_selection =~ s!/$!! unless $user_selection =~ m!^/$!; $user_selection =~ s!/\./!/!g; $user_selection =~ s!/+!/!g; last FSEL; } elsif (-d $path."/".$list->[($user_selection - 1 || 0)]) { $path = $path."/".$list->[($user_selection - 1 || 0)]; } elsif (-e $path."/".$list->[($user_selection - 1 || 0)]) { $user_selection = $path."/".$list->[($user_selection - 1 || 0)]; $user_selection =~ s!/$!! unless $user_selection =~ m!^/$!; $user_selection =~ s!/\./!/!g; $user_selection =~ s!/+!/!g; last FSEL; } } $user_selection = undef(); $path =~ s!(/*)!/!; $path =~ s!/\./!/!g; } $self->_beep($args->{'beepafter'}); my $rv = $self->rv(); $self->ra('NULL'); if ($rv && $rv >= 1) { $self->rs('NULL'); return(0); } else { $self->rs($user_selection); return($user_selection); } } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: directory selection sub dselect { my $self = shift(); my $caller = (caller(1))[3] || 'main'; $caller = ($caller =~ /^UI\:\:Dialog\:\:Backend\:\:/) ? ((caller(2))[3]||'main') : $caller; if ($_[0] && $_[0] eq 'caller') { shift(); $caller = shift(); } my $args = $self->_pre($caller,@_); my $dirname; $self->rv('NULL'); $self->rs('NULL'); $self->ra('NULL'); while (not $dirname && $self->state() !~ /^(CANCEL|ESC|ERROR)$/) { $dirname = $self->fselect(@_,'dselect',1); if ($self->state() =~ /^(CANCEL|ESC|ERROR)$/) { return(0); } unless (not $dirname) { # if it's a directory or not exist (assume new dir) unless (-d $dirname || not -e $dirname) { $self->msgbox( text => $dirname . " is not a directory.\nPlease select a directory." ); $dirname = undef(); } } } return($dirname||''); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Backend Methods #: sub _pre { my $self = shift(); my $caller = shift(); my $args = $self->_merge_attrs(@_); $args->{'caller'} = $caller; my $class = ref($self); my $CODEREFS = $args->{'callbacks'}; if (ref($CODEREFS) eq "HASH") { my $PRECODE = $CODEREFS->{'PRE'}; if (ref($PRECODE) eq "CODE") { &$PRECODE($args,$self->state()); } } $self->_beep($args->{'beepbefore'}); $self->_clear($args->{'clearbefore'}); return($args); } sub _post { my $self = shift(); my $args = shift() || {}; my $class = ref($self); $self->_beep($args->{'beepafter'}); $self->_clear($args->{'clearafter'}); my $CODEREFS = $args->{'callbacks'}; if (ref($CODEREFS) eq "HASH") { my $state = $self->state(); if ($state eq "OK") { my $OKCODE = $CODEREFS->{'OK'}; if (ref($OKCODE) eq "CODE") { &$OKCODE($args); } } elsif ($state eq "ESC") { my $ESCCODE = $CODEREFS->{'ESC'}; if (ref($ESCCODE) eq "CODE") { &$ESCCODE($args); } } elsif ($state eq "CANCEL") { my $CANCELCODE = $CODEREFS->{'CANCEL'}; if (ref($CANCELCODE) eq "CODE") { &$CANCELCODE($args); } } my $POSTCODE = $CODEREFS->{'POST'}; if (ref($POSTCODE) eq "CODE") { &$POSTCODE($args,$state); } } return(1); } #: indent and organize the text argument sub _organize_text { my $self = $_[0]; my $text = $_[1]; my $width = $_[2] || 65; my $trust = (exists $_[3] && defined $_[3]) ? $_[3] : '0'; $width -= 4; # take account of borders? my @array; if (ref($text) eq "ARRAY") { push(@array,@{$text}); } elsif ($text =~ /\\n/) { @array = split(/\\n/,$text); } else { @array = split(/\n/,$text); } $text = undef; @array = $self->word_wrap($width,"","",@array); if ($self->{'scale'}) { foreach my $line (@array) { my $s_line = $line;#$self->__TRANSLATE_CLEAN($line); $s_line =~ s!\[A\=\w+\]!!gi; $self->{'width'} = length($s_line) + 5 if ($self->{'width'} - 5) < length($s_line) && (length($s_line) <= $self->{'max-scale'}); } } foreach my $line (@array) { my $pad; $self->clean_format( $trust, \$line ); my $s_line = $self->_strip_text($line); if ($line =~ /\[A\=(\w+)\]/i) { my $align = $1; $line =~ s!\[A\=\w+\]!!gi; if (uc($align) eq "CENTER" || uc($align) eq "C") { $pad = ((($self->{'_opts'}->{'width'} - 5) - length($s_line)) / 2); } elsif (uc($align) eq "LEFT" || uc($align) eq "L") { $pad = 0; } elsif (uc($align) eq "RIGHT" || uc($align) eq "R") { $pad = (($self->{'_opts'}->{'width'} - 5) - length($s_line)); } } if ($pad) { $text .= (" " x $pad).$line."\n"; } else { $text .= $line."\n"; } } $text = $self->_strip_text($text); chomp($text) if $text; return($text); } #: merge the arguments with the default attributes, and arguments override defaults. sub _merge_attrs { my $self = shift(); my $args = (@_ % 2) ? { @_, '_odd' } : { @_ }; my $defs = $self->{'_opts'}; foreach my $def (keys(%$defs)) { # default unless exists $args->{$def} = $defs->{$def} unless exists $args->{$def}; } # alias 'filename' and 'file' to path $args->{'path'} = (($args->{'filename'}) ? $args->{'filename'} : ($args->{'file'}) ? $args->{'file'} : ($args->{'path'}) ? $args->{'path'} : ""); $args->{'clear'} = $args->{'clearbefore'} || $args->{'clearafter'} || $args->{'autoclear'} || 0; $args->{'beep'} = $args->{'beepbefore'} || $args->{'beepafter'} || $args->{'autobeep'} || 0; return($args); } #: search through the given paths for a specific variant sub _find_bin { my $self = $_[0]; my $variant = $_[1]; $self->{'PATHS'} = ((ref($self->{'PATHS'}) eq "ARRAY") ? $self->{'PATHS'} : ($self->{'PATHS'}) ? [ $self->{'PATHS'} ] : [ '/bin', '/usr/bin', '/usr/local/bin', '/opt/bin' ]); foreach my $PATH (@{$self->{'PATHS'}}) { return($PATH . '/' . $variant) unless not -x $PATH . '/' . $variant; } return(0); } #: clean the text arguments of all colour codes, alignments and attributes. sub _strip_text { my $self = $_[0]; my $text = $_[1]; $text ||= ''; $text =~ s!\\Z[0-7bBuUrRn]!!gmi; $text =~ s!\[[AC]=\w+\]!!gmi; $text =~ s!\[/?[BURN]\]!!gmi; return($text); } #: is this a BSD system? sub _is_bsd { my $self = shift(); return(1) if $^O =~ /bsd/i; return(0); } #: gather a list of the contents of a directory and return it in #: two forms, one is the "simple" list of all the filenames and the #: other is a 'menu' list corresponding to the simple list. sub _list_dir { my $self = shift(); my $path = shift() || return(); my $pref = shift(); my $paths_only = (@_ == 1 && $_[0] == 1) ? 1 : 0; my (@listing,@list); if (opendir(GETDIR,$path)) { my @dir_data = readdir(GETDIR); closedir(GETDIR); if ($pref) { push(@listing,@{$pref}); } foreach my $dir (sort(grep { -d $path."/".$_ } @dir_data)) { push(@listing,$dir."/"); } unless ($paths_only) { foreach my $item (sort(grep { !-d $path."/".$_ } @dir_data)) { push(@listing,$item); } } my $c = 1; foreach my $item (@listing) { push(@list,"$c",$item); $c++; } return(\@list,\@listing); } else { return("failed to read directory: ".$path); } } sub _debug { my $self = $_[0]; my $mesg = $_[1] || 'null debug message given!'; my $rate = $_[2] || 1; return() unless $self->{'_opts'}->{'debug'} and $self->{'_opts'}->{'debug'} >= $rate; chomp($mesg); print STDERR "Debug: ".$mesg."\n"; } sub _error { my $self = $_[0]; my $mesg = $_[1] || 'null error message given!'; chomp($mesg); print STDERR "Error: ".$mesg."\n"; } #: really make some noise sub _beep { my $self = $_[0]; my $beep = $_[1]; unless (not $beep) { if (-x $self->{'_opts'}->{'beepbin'}) { return(eval { system($self->{'_opts'}->{'beepbin'}); 1; }); } else { return (1) unless $ENV{'TERM'} && $ENV{'TERM'} ne "dumb"; print STDERR "\a"; } } return(1); } #: The actual clear action. sub _clear { my $self = $_[0]; my $clear = $_[1] || 0; # Useless with GUI based variants so we return here. # Is the use of the "dumb" TERM appropriate? need feedback. return (1) unless $ENV{'TERM'} && $ENV{'TERM'} ne "dumb"; unless (not $clear and not $self->{'_opts'}->{'autoclear'}) { $self->{'_clear'} ||= `clear`; print STDOUT $self->{'_clear'}; } return(1); } 1; PK ! �9��� � Dialog/KDE.pmnu ��6�$ package UI::Dialog::KDE; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; use UI::Dialog; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog ); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = {@_} || {}; my $self = {}; bless($self, $class); $self->{'debug'} = $cfg->{'debug'} || 0; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } $cfg->{'order'} ||= [ 'kdialog', 'xdialog' ]; $self->_debug("ENV->UI_DIALOGS: ".($ENV{'UI_DIALOGS'}||'NULL'),2); $cfg->{'order'} = [ split(/\:/,$ENV{'UI_DIALOGS'}) ] if $ENV{'UI_DIALOGS'}; $self->_debug("ENV->UI_DIALOG: ".($ENV{'UI_DIALOG'}||'NULL'),2); unshift(@{$cfg->{'order'}},$ENV{'UI_DIALOG'}) if $ENV{'UI_DIALOG'}; $cfg->{'trust-input'} = ( exists $cfg->{'trust-input'} && $cfg->{'trust-input'}==1 ) ? 1 : 0; my @opts = (); foreach my $opt (keys(%$cfg)) { push(@opts,$opt,$cfg->{$opt}); } foreach my $try (@{$cfg->{'order'}}) { if ($try =~ /^kdialog$/i) { $self->_debug("trying kdialog",2); if (eval "require UI::Dialog::Backend::KDialog; 1" && $self->_has_variant('kdialog')) { require UI::Dialog::Backend::KDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::KDialog (@opts); $self->_debug("using kdialog",2); last; } else { next; } } elsif ($try =~ /^(?:xdialog||X)$/i) { $self->_debug("trying xdialog",2); if (eval "require UI::Dialog::Backend::XDialog; 1" && $self->_has_variant('Xdialog')) { require UI::Dialog::Backend::XDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::XDialog (@opts,'XDIALOG_HIGH_DIALOG_COMPAT',1); $self->_debug("using xdialog",2); last; } else { next; } } else { # we don't know what they're asking for... try UI::Dialog... if (eval "require UI::Dialog; 1") { require UI::Dialog; $self->{'_ui_dialog'} = new UI::Dialog (@opts); $self->_debug(ref($self)." unknown backend: '".$try."', using UI::Dialog instead.",2); last; } else { next; } } } ref($self->{'_ui_dialog'}) or croak("unable to load suitable backend."); return($self); } 1; PK ! �Ǵ(�J �J Dialog.pmnu ��6�$ package UI::Dialog; ############################################################################### # Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### use 5.006; use strict; use warnings; use Carp; BEGIN { use vars qw($VERSION); $VERSION = '1.21'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Constructor Method #: sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $cfg = {@_} || {}; my $self = {}; bless($self, $class); $self->{'debug'} = $cfg->{'debug'} || 0; #: Dynamic path discovery... my $CFG_PATH = $cfg->{'PATH'}; if ($CFG_PATH) { if (ref($CFG_PATH) eq "ARRAY") { $self->{'PATHS'} = $CFG_PATH; } elsif ($CFG_PATH =~ m!:!) { $self->{'PATHS'} = [ split(/:/,$CFG_PATH) ]; } elsif (-d $CFG_PATH) { $self->{'PATHS'} = [ $CFG_PATH ]; } } elsif ($ENV{'PATH'}) { $self->{'PATHS'} = [ split(/:/,$ENV{'PATH'}) ]; } else { $self->{'PATHS'} = ''; } if (not $cfg->{'order'} and ($ENV{'DISPLAY'} && length($ENV{'DISPLAY'}) > 0)) { #: Pick a GUI mode 'cause a DISPLAY was detected if ($ENV{'TERM'} =~ /^dumb$/i) { # we're running free of a terminal $cfg->{'order'} = [ 'zenity', 'xdialog', 'gdialog', 'kdialog' ]; } else { # we're running in a terminal $cfg->{'order'} = [ 'zenity', 'xdialog', 'gdialog', 'kdialog', 'whiptail', 'cdialog', 'ascii' ]; } } # verify and repair the order $cfg->{'order'} = ((ref($cfg->{'order'}) eq "ARRAY") ? $cfg->{'order'} : ($cfg->{'order'}) ? [ $cfg->{'order'} ] : [ 'cdialog', 'whiptail', 'ascii' ]); $self->_debug("ENV->UI_DIALOGS: ".($ENV{'UI_DIALOGS'}||'NULL'),2); $cfg->{'order'} = [ split(/\:/,$ENV{'UI_DIALOGS'}) ] if $ENV{'UI_DIALOGS'}; $self->_debug("ENV->UI_DIALOG: ".($ENV{'UI_DIALOG'}||'NULL'),2); unshift(@{$cfg->{'order'}},$ENV{'UI_DIALOG'}) if $ENV{'UI_DIALOG'}; $cfg->{'trust-input'} = ( exists $cfg->{'trust-input'} && $cfg->{'trust-input'}==1 ) ? 1 : 0; my @opts = (); foreach my $opt (keys(%$cfg)) { push(@opts,$opt,$cfg->{$opt}); } $self->_debug("order: @{$cfg->{'order'}}",2); if (ref($cfg->{'order'}) eq "ARRAY") { foreach my $try (@{$cfg->{'order'}}) { if ($try =~ /^zenity$/i) { $self->_debug("trying zenity",2); if (eval "require UI::Dialog::Backend::Zenity; 1" && $self->_has_variant('zenity')) { require UI::Dialog::Backend::Zenity; $self->{'_ui_dialog'} = new UI::Dialog::Backend::Zenity (@opts); $self->_debug("using zenity",2); last; } else { next; } } elsif ($try =~ /^(?:gdialog|gdialog\.real)$/i) { $self->_debug("trying gdialog",2); #: In Debian, gdialog is now being diverted to gdialog.real as zenity is the gnome2 replacement if (eval "require UI::Dialog::Backend::GDialog; 1" && ($self->_has_variant('gdialog.real') || $self->_has_variant('gdialog'))) { require UI::Dialog::Backend::GDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::GDialog (@opts); $self->_debug("using gdialog ",2); last; } else { next; } } elsif ($try =~ /^(?:xdialog|X)$/i) { $self->_debug("trying xdialog",2); if (eval "require UI::Dialog::Backend::XDialog; 1" && $self->_has_variant('Xdialog')) { require UI::Dialog::Backend::XDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::XDialog (@opts,'XDIALOG_HIGH_DIALOG_COMPAT',1); $self->_debug("using xdialog",2); last; } else { next; } } elsif ($try =~ /^kdialog$/i) { $self->_debug("trying kdialog",2); if (eval "require UI::Dialog::Backend::KDialog; 1" && $self->_has_variant('kdialog')) { require UI::Dialog::Backend::KDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::KDialog (@opts); $self->_debug("using kdialog",2); last; } else { next; } } elsif ($try =~ /^GNOME$/i) { if (eval "require UI::Dialog::GNOME; 1") { require UI::Dialog::GNOME; $self->{'_ui_dialog'} = new UI::Dialog::GNOME (@opts); last; } else { next; } } elsif ($try =~ /^KDE$/i) { if (eval "require UI::Dialog::KDE; 1") { require UI::Dialog::KDE; $self->{'_ui_dialog'} = new UI::Dialog::KDE (@opts); last; } else { next; } } elsif ($try =~ /^CONSOLE$/i) { if (eval "require UI::Dialog::Console; 1") { require UI::Dialog::Console; $self->{'_ui_dialog'} = new UI::Dialog::Console (@opts); last; } else { next; } } elsif ($try =~ /^(?:dialog|cdialog)$/i) { $self->_debug("trying cdialog",2); if (eval "require UI::Dialog::Backend::CDialog; 1" && $self->_has_variant('dialog')) { require UI::Dialog::Backend::CDialog; $self->{'_ui_dialog'} = new UI::Dialog::Backend::CDialog (@opts); $self->_debug("using cdialog",2); last; } else { next; } } elsif ($try =~ /^whiptail$/i) { $self->_debug("trying whiptail",2); if (eval "require UI::Dialog::Backend::Whiptail; 1" && $self->_has_variant('whiptail')) { require UI::Dialog::Backend::Whiptail; $self->{'_ui_dialog'} = new UI::Dialog::Backend::Whiptail (@opts); $self->_debug("using whiptail",2); last; } else { next; } } elsif ($try =~ /^(?:ascii|native)$/i) { $self->_debug("trying ascii",2); if (eval "require UI::Dialog::Backend::ASCII; 1") { require UI::Dialog::Backend::ASCII; $self->{'_ui_dialog'} = new UI::Dialog::Backend::ASCII (@opts); $self->_debug("using ascii",2); last; } else { next; } } else { next; } } } else { if (eval "require UI::Dialog::Backend::ASCII; 1") { require UI::Dialog::Backend::ASCII; $self->{'_ui_dialog'} = new UI::Dialog::Backend::ASCII (@opts); } else { carp("Failed to load any suitable dialog variant backend."); } } ref($self->{'_ui_dialog'}) or croak("unable to load suitable backend."); return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: #: purely internal usage sub _debug { my $self = $_[0]; my $mesg = $_[1] || 'null error message given!'; my $rate = $_[2] || 1; return() unless $self->{'debug'} and $self->{'debug'} >= $rate; chomp($mesg); print STDERR "Debug: ".$mesg."\n"; } sub _has_variant { my $self = $_[0]; my $variant = $_[1]; $self->{'PATHS'} = ((ref($self->{'PATHS'}) eq "ARRAY") ? $self->{'PATHS'} : ($self->{'PATHS'}) ? [ $self->{'PATHS'} ] : [ '/bin', '/usr/bin', '/usr/local/bin', '/opt/bin' ]); foreach my $PATH (@{$self->{'PATHS'}}) { return($PATH . '/' . $variant) unless not -x $PATH . '/' . $variant; } return(0); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Public Methods #: #: dialog variant state methods: sub state { return(shift()->{'_ui_dialog'}->state(@_)); } sub ra { return(shift()->{'_ui_dialog'}->ra(@_)); } sub rs { return(shift()->{'_ui_dialog'}->rs(@_)); } sub rv { return(shift()->{'_ui_dialog'}->rv(@_)); } #: Frills #: all backends support nautilus scripts. sub nautilus { return(shift()->{'_ui_dialog'}->nautilus(@_)); } #: same with osd_cat (aka: xosd). sub xosd { return(shift()->{'_ui_dialog'}->xosd(@_)); } #: Beep & Clear may have no affect when using GUI backends sub beep { return(shift()->{'_ui_dialog'}->beep(@_)); } sub clear { return(shift()->{'_ui_dialog'}->clear(@_)); } #: widget methods: sub yesno { return(shift()->{'_ui_dialog'}->yesno(@_)); } sub msgbox { return(shift()->{'_ui_dialog'}->msgbox(@_)); } sub inputbox { return(shift()->{'_ui_dialog'}->inputbox(@_)); } sub password { return(shift()->{'_ui_dialog'}->password(@_)); } sub textbox { return(shift()->{'_ui_dialog'}->textbox(@_)); } sub menu { return(shift()->{'_ui_dialog'}->menu(@_)); } sub checklist { return(shift()->{'_ui_dialog'}->checklist(@_)); } sub radiolist { return(shift()->{'_ui_dialog'}->radiolist(@_)); } sub fselect { return(shift()->{'_ui_dialog'}->fselect(@_)); } sub dselect { return(shift()->{'_ui_dialog'}->dselect(@_)); } 1; =head1 NAME UI::Dialog - wrapper for various dialog applications. =head1 SYNOPSIS use UI::Dialog; my $d = new UI::Dialog ( backtitle => 'Demo', title => 'Default', height => 20, width => 65 , listheight => 5, order => [ 'zenity', 'xdialog' ] ); # Either a Zenity or Xdialog msgbox widget should popup, # with a preference for Zenity. $d->msgbox( title => 'Welcome!', text => 'Welcome one and all!' ); =head1 ABSTRACT UI::Dialog is a OOPerl wrapper for the various dialog applications. These dialog backends are currently supported: Zenity, XDialog, GDialog, KDialog, CDialog, and Whiptail. There is also an ASCII backend provided as a last resort interface for the console based dialog variants. UI::Dialog is a class that provides a strict interface to these various backend modules. By using UI:Dialog (with it's imposed limitations on the widgets) you can ensure that your Perl program will function with any available interfaces. =head1 DESCRIPTION UI::Dialog supports priority ordering of the backend detection process. So if you'd prefer that Xdialog should be used first if available, simply designate the desired order when creating the new object. The default order for detecting and utilization of the backends are as follows: (with DISPLAY env): Zenity, GDialog, XDialog, KDialog (without DISPLAY): CDialog, Whiptail, ASCII UI::Dialog is the result of a complete re-write of the UDPM CPAN module. This was done to break away from the bad choice of name (UserDialogPerlModule) and to implement a cleaner, more detached, OOPerl interface. =head1 EXPORT =over 2 None =back =head1 INHERITS =over 2 None =back =head1 CONSTRUCTOR =over 2 =back =head2 new( @options ) =over 4 =item EXAMPLE =over 6 my $d = new( title => 'Default Title', backtitle => 'Backtitle', width => 65, height => 20, listheight => 5, order => [ 'zenity', 'xdialog', 'gdialog' ] ); =back =item DESCRIPTION =over 6 This is the Class Constructor method. It accepts a list of key => value pairs and uses them as the defaults when interacting with the various widgets. =back =item RETURNS =over 6 A blessed object reference of the UI::Dialog class. =back =item OPTIONS The (...)'s after each option indicate the default for the option. An * denotes support by all the widget methods on a per-use policy defaulting to the values decided during object creation. =over 6 =item B<debug = 0,1,2> (0) =item B<order = [ zenity, xdialog, gdialog, kdialog, cdialog, whiptail, ascii ]> (as indicated) =item B<PATH = [ /bin, /usr/bin, /usr/local/bin, /opt/bin ]> (as indicated) =item B<backtitle = "backtitle"> ('') * =item B<title = "title"> ('') * =item B<beepbefore = 0,1> (0) * =item B<beepafter = 0,1> (0) * =item B<height = \d+> (20) * =item B<width = \d+> (65) * =item B<listheight = \d+> (5) * =back =back =head1 STATE METHODS =over 2 =back =head2 state( ) =over 4 =item EXAMPLE =over 6 if ($d->state() eq "OK") { $d->msgbox( text => "that went well" ); } =back =item DESCRIPTION =over 6 Returns the state of the last dialog widget command. The value can be one of "OK", "CANCEL", "ESC". The return data is based on the exit codes (return value) of the last widget displayed. =back =item RETURNS =over 6 a single SCALAR. =back =back =over 2 =back =head2 ra( ) =over 4 =item EXAMPLE =over 6 my @array = $d->ra(); =back =item DESCRIPTION =over 6 Returns the last widget's data as an array. =back =item RETURNS =over 6 an ARRAY. =back =back =over 2 =back =head2 rs( ) =over 4 =item EXAMPLE =over 6 my $string = $d->rs(); =back =item DESCRIPTION =over 6 Returns the last widget's data as a (possibly multiline) string. =back =item RETURNS =over 6 a SCALAR. =back =back =over 2 =back =head2 rv( ) =over 4 =item EXAMPLE =over 6 my $string = $d->rv(); =back =item DESCRIPTION =over 6 Returns the last widget's exit status, aka: return value. =back =item RETURNS =over 6 a SCALAR. =back =back =head1 WIDGET METHODS =over 2 =back =head2 yesno( ) =over 4 =item EXAMPLE =over 6 if ($d->yesno( text => 'A binary type question?') ) { # user pressed yes } else { # user pressed no or cancel } =back =item DESCRIPTION =over 6 Present the end user with a message box that has two buttons, yes and no. =back =item RETURNS =over 6 TRUE (1) for a response of YES or FALSE (0) for anything else. =back =back =over 2 =back =head2 msgbox( ) =over 4 =item EXAMPLE =over 6 $d->msgbox( text => 'A simple message' ); =back =item DESCRIPTION =over 6 Pesent the end user with a message box that has an OK button. =back =item RETURNS =over 6 TRUE (1) for a response of OK or FALSE (0) for anything else. =back =back =over 2 =back =head2 inputbox( ) =over 4 =item EXAMPLE =over 6 my $string = $d->inputbox( text => 'Please enter some text...', entry => 'this is the input field' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field and a message. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =over 2 =back =head2 password( ) =over 4 =item EXAMPLE =over 6 my $string = $d->password( text => 'Enter some hidden text.' ); =back =item DESCRIPTION =over 6 Present the end user with a text input field, that has hidden input, and a message. Note that the GDialog backend will provide a regular inputbox instead of a password box because gdialog doesn't support passwords. GDialog is on it's way to the proverbial software heaven so this isn't a real problem. Use Zenity instead :) =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =over 2 =back =head2 textbox( ) =over 4 =item EXAMPLE =over 6 $d->textbox( path => '/path/to/a/text/file' ); =back =item DESCRIPTION =over 6 Present the end user with a simple scrolling box containing the contents of the given text file. =back =item RETURNS =over 6 TRUE (1) if the response is OK and FALSE (0) for anything else. =back =back =over 2 =back =head2 menu( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->menu( text => 'Select one:', list => [ 'tag1', 'item1', 'tag2', 'item2', 'tag3', 'item3' ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable list. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =over 2 =back =head2 checklist( ) =over 4 =item EXAMPLE =over 6 my @selection1 = $d->checklist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 1 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable checklist. =back =item RETURNS =over 6 an ARRAY of the chosen tags if the response is OK and FALSE (0) for anything else. =back =back =over 2 =back =head2 radiolist( ) =over 4 =item EXAMPLE =over 6 my $selection1 = $d->radiolist( text => 'Select one:', list => [ 'tag1', [ 'item1', 0 ], 'tag2', [ 'item2', 1 ], 'tag3', [ 'item3', 0 ] ] ); =back =item DESCRIPTION =over 6 Present the user with a selectable radiolist. =back =item RETURNS =over 6 a SCALAR of the chosen tag if the response is OK and FALSE (0) for anything else. =back =back =over 2 =back =head2 fselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->fselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =over 2 =back =head2 dselect( ) =over 4 =item EXAMPLE =over 6 my $text = $d->dselect( path => '/path/to/a/file/or/directory' ); =back =item DESCRIPTION =over 6 Present the user with a file selection widget preset with the given path. Unlike fselect() this widget will only return a directory selection. =back =item RETURNS =over 6 a SCALAR if the response is OK and FALSE (0) for anything else. =back =back =head1 SEE ALSO =over 2 =item PERLDOC UI::Dialog::GNOME UI::Dialog::KDE UI::Dialog::Console UI::Dialog::Backend UI::Dialog::Backend::ASCII UI::Dialog::Backend::CDialog UI::Dialog::Backend::GDialog UI::Dialog::Backend::KDialog UI::Dialog::Backend::Nautilus UI::Dialog::Backend::Whiptail UI::Dialog::Backend::XDialog UI::Dialog::Backend::XOSD UI::Dialog::Backend::Zenity =back =over 2 =item MAN FILES dialog(1), whiptail(1), zenity(1), gdialog(1), Xdialog(1), osd_cat(1), kdialog(1) and nautilus(1) =back =head1 BUGS Please email the author with any bug reports. Include the name of the module in the subject line. =head1 AUTHOR Kevin C. Krinke, E<lt>kevin@krinke.caE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2016 Kevin C. Krinke <kevin@krinke.ca> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut PK ! 5��C) C) Dialog.podnu ��6�$ PK ! ���;b b }) Dialog/GNOME.podnu ��6�$ PK ! *�m�� � 9 Dialog/Gauged.pmnu ��6�$ PK ! u��!� � QW Dialog/Console.podnu ��6�$ PK ! �w�� � �c Dialog/Gauged.podnu ��6�$ PK ! ����� � �w Dialog/Console.pmnu ��6�$ PK ! � ܙ~D ~D �� Dialog/Backend.podnu ��6�$ PK ! Y��� � T� Dialog/GNOME.pmnu ��6�$ PK ! ��$7 7 v� Dialog/KDE.podnu ��6�$ PK ! �9" T' T' �� Dialog/Backend/Zenity.podnu ��6�$ PK ! t��� � Dialog/Backend/Nautilus.pmnu ��6�$ PK ! �����s �s �( Dialog/Backend/CDialog.pmnu ��6�$ PK ! ��.v v �� Dialog/Backend/XOSD.podnu ��6�$ PK ! q� � � _� Dialog/Backend/Nautilus.podnu ��6�$ PK ! g�o�Q �Q y� Dialog/Backend/Zenity.pmnu ��6�$ PK ! SL�T�� �� � Dialog/Backend/XDialog.pmnu ��6�$ PK ! �c�|r. r. �� Dialog/Backend/CDialog.podnu ��6�$ PK ! 5[��-- -- � Dialog/Backend/XOSD.pmnu ��6�$ PK ! C���2 �2 3 Dialog/Backend/KDialog.pmnu ��6�$ PK ! ��u�' �' 8f Dialog/Backend/GDialog.pmnu ��6�$ PK ! �� ��b �b #� Dialog/Backend/XDialog.podnu ��6�$ PK ! ��� j� j� &� Dialog/Backend/ASCII.pmnu ��6�$ PK ! S�+�M& M& � Dialog/Backend/GDialog.podnu ��6�$ PK ! �z�� � n� Dialog/Backend/KDialog.podnu ��6�$ PK ! `c�`% `% �� Dialog/Backend/ASCII.podnu ��6�$ PK ! i�Gk% k% :� Dialog/Backend/Whiptail.podnu ��6�$ PK ! 8ߌ/�; �; � Dialog/Backend/Whiptail.pmnu ��6�$ PK ! �Q�� # # N Dialog/Screen/Menu.podnu ��6�$ PK ! ��Y Y wq Dialog/Screen/Menu.pmnu ��6�$ PK ! ��{<m m � Dialog/Screen/Druid.podnu ��6�$ PK ! �{� � ɣ Dialog/Screen/Druid.pmnu ��6�$ PK ! �)��d �d ٻ Dialog/Backend.pmnu ��6�$ PK ! �9��� � � Dialog/KDE.pmnu ��6�$ PK ! �Ǵ(�J �J �. Dialog.pmnu ��6�$ PK " " O �y
| ver. 1.1 | |
.
| PHP 8.4.18 | Ð“ÐµÐ½ÐµÑ€Ð°Ñ†Ð¸Ñ Ñтраницы: 0.96 |
proxy
|
phpinfo
|
ÐаÑтройка