UI-Dialog-1.09/000755 000765 000024 00000000000 12204450137 013536 5ustar00onest8staff000000 000000 UI-Dialog-1.09/Changes000644 000765 000024 00000031120 12202472000 015015 0ustar00onest8staff000000 000000 1.09 - Sat, 10 Aug 2013 03:04:42 -0500 * Updated author email address, finally * Added new UI::Dialog::Screen::Menu class * POD tweaks ala Debian packaging patch * Resolved CPAN tickets: 35289, 33365, 18134, 32706, 82093 -- Kevin C. Krinke 1.08 - Sat, 02 Oct 2004 00:05:34 -0400 * UI::Dialog::Backend::Nautilus now correctly determins the user's desktop directory using Gnome2::GConf (if found) or via kludge. * Bugfix for improper Zenity version string handling -- Kevin C. Krinke 1.07 - Wed, 21 Jul 2004 14:52:30 -0500 * Bugfix for checklist failing to work with an empty user selection -- Kevin C. Krinke 1.06 - Thu, 18 Mar 2004 10:55:24 -0500 * Bugfix for dynamic path discovery. -- Kevin C. Krinke 1.05 - Wed, 17 Mar 2004 18:26:44 -0500 * Added infobox() to CDialog and Whiptail POD * Added calendar(), timebox() and tailbox() to CDialog POD * Now chomping calendar() and timebox() results * CDialog case handling for ancient version 0.3 * Dynamic PATH discovery; hard coded or $ENV{'PATH'} or default * Implemented form() method for CDialog * "literal" option now forces --no-collapse for CDialog * Updated CONTRIBUTORS file, now gives credit for what they did too -- Kevin C. Krinke 1.04 - Sun, 22 Feb 2004 13:28:35 -0500 * fixed the use of Temp::File with qw( tempfile )... * ((note to self; remember to test with _all_ variants before release)) -- Kevin C. Krinke 1.03 - Wed, 18 Feb 2004 11:35:54 -0500 * fix for running in X but in a terminal. If there are no gui dialog variants it will now fallback to available console based variants. * Stopped undeffing for a slurp and instead use the localized slurp. (doh! my bad!) * Use tempfile() instead of File::Temp::mktemp. * POD fix for UI::Dialog referring to menubox() when it should be menu() * Whiptail needs the width adjusted by 4 to take into account the borders. * Added in 'literal' option to supress the organization and translation of text. * UI::Dialog::Backend::CDialog no longer has hard coded version dependancies (Debian unstable updates no longer break UI::Dialog::Backend::CDialog). * UI::Dialog::Backend::CDialog no longer messes up by redirecting STDERR to STDOUT via 2>&1 in system() calls * Fixed security issues with CDialog and Whiptail backends and their usage of the temp files. * Removed all warning and diagnostic pragmas. * Added/Updated CONTRIBUTORS file with special thanks to Julian Gilbey and Alfonso E.M. * ((Note to self... remember to add my name at the end of each changelog entry and date to the version line)) -- Kevin C. Krinke 1.02 * Added editbox() widget to UI::Dialog::GNOME * Updated UI::Dialog::GNOME pod to include editbox() widget with a gdialog warning in the description of the UI::Dialog::GNOME module * Updated UI::Dialog::Backend::Zenity pod to include editbox() widget 1.01 * Bugfix from Alfonso E.M. for XDialog cancellabel * updated tests to skip_all that are binary dependant (all except ASCII) 1.00 * Whitespace fixes * Updates to UI::Dialog::Charts * meta-classes now default to UI::Dialog when an unknown variant is selected via $ENV * Updated CDialog for new version in Debian unstable -- Kevin C. Krinke 0.21 - Mon, 10 Nov 2003 18:59:02 -0500 * Updated tests and POD -- Kevin C. Krinke 0.20 - Mon, 10 Nov 2003 15:43:40 -0500 * Migrating debian/changelog to Changes * updated UI::Dialog::Backend::Nautilus for GNOME 2.4 inconsistencies -- Kevin C. Krinke 0.19 - Wed, 17 Sep 2003 20:34:09 -0400 * updated CDialog.pm for Debian dialog version 20030910 -- Kevin C. Krinke 0.18 - Tue, 9 Sep 2003 22:50:05 -0400 * migrated all the POD to *.pod files * eliminated all "ERRORS" from POD using podchecker * inserted copyright notice at the top of each .pm * migrated all code to lib/UI/ * updated Makefile.PL and such to suite the changes * fixed typo "sinle" -> "single" in 3 places * implemented little pod2html shell script * made html of pod in ./pod.html/ -- Kevin C. Krinke 0.17 - Wed, 27 Aug 2003 04:14:52 -0400 * implemented xosd->display_*() methods (like a gauge widget but not) * enabled passing of XOSD config options via first $d->xosd() call * enhanced examples/xosd.pl to suite display_*() feature -- Kevin C. Krinke 0.16 - Thu, 7 Aug 2003 23:45:51 -0400 * RC3 Yet more beta goodness... * _strip_text() now removes closing meta blocks (like: [/b]) * Backend.pm now mentions the ->xosd-> and ->nautilus-> extensions * tweaked meta-class POD ABSTRACT and DESCRIPTION sections * replaced 'error' with ' ' where appropriate * fixed POD for gauge_text(), the example showed gauge_set( "string" ); * Zenity now has a "dummy" gauge_text() method for Gauged.pm compliance * implemented UI::Dialog::Gauged meta-class (same as UI::Dialog but for dialogs with gauges) * updated make and rules files for UI::Dialog::Gauged -- Kevin C. Krinke 0.15 - Sat, 2 Aug 2003 04:18:05 -0400 * RC2 Still Beta Release... * KDE.pm now loads kdialog properly instead of (typoed) xdialog -- Kevin C. Krinke 0.14 - Sat, 2 Aug 2003 03:18:50 -0400 * This is the RC1 Beta release!!! (yuppers, time to go public!) * corrected inconsistent state handling * repaired ->ra() to return an array of the data (kill array ref madness) * repaired ASCII escaping issues (reimplemented _merge_attrs()) * all yesno() widgets set ra() and rs() with either "YES" or "NO" * set the default height of the XDialog calendar & timebox to 14 * repaired gauge widget FH issues * beautified and repaired various examples/*.pl * examples/{gnome,kde,console,ui-dialog}.pl are now simply a single msgbox() * updated Makefile.PL, TODO, and Changes -- Kevin C. Krinke 0.13 - Fri, 1 Aug 2003 23:56:35 -0400 * unified all gauge_*() widgets * returned usleep() to sleep() as it really wasn't doing the right thing. -- Kevin C. Krinke 0.12 - Thu, 31 Jul 2003 20:58:51 -0400 * implemented ASCII support for callbacks * repaired ASCII gauge * renamed gauge() to draw_gauge() and gauge_end() to end_gauge() * cleaned up & unified "clear" and "beep" construction-time arguments * 'beep' and 'clear' arguments are now set if beep|clearbefore|after exist * Makefile.PL updated with Text::Wrap dependancy * MANIFESTed examples/console.pl * examples/{console,gnome,kde,ui-dialog}.pl are now simplified * 'null-caller-fix' propagated to all backends * clear added to _pre() and _post() * ASCII widgets shortened by 1 line to fit in 80x24 terminals * implemented ASCII infobox() widget * all console infobox widgets now use Time::HiRes::usleep() * ASCII gauge and spinner added to POD * 'timeout' and 'wait' arguments propagated to all backends * inappropriate 'beeps' and 'clears' removed * BEGIN blocks unified across all modules * examples/ascii.pl revisited -- Kevin C. Krinke 0.11 - Thu, 31 Jul 2003 11:52:36 -0400 * repaired array ref "text" strings (text => [ 'some stuff..', 'next line' ]) * implemented gdialog support for callbacks * updated gdialog POD * revised examples/gdialog.pl -- Kevin C. Krinke 0.10 - Wed, 30 Jul 2003 19:04:29 -0400 * kdialog now supports the callback system * updated examples/kdialog.pl * revised the UI::Dialog::Backend::KDialog POD -- Kevin C. Krinke 0.09 - Wed, 30 Jul 2003 05:07:40 -0400 * implemented "smart" usage of File::Temp/mktemp/built-in-solution to temp file name generation -- Kevin C. Krinke 0.08 - Wed, 30 Jul 2003 01:11:26 -0400 * whiptail now supports callbacks properly * POD tweaks to a bunch of files * examples/whiptail.pl updated to latest example format * solved whiptail "screen-no-show" bug (command() instead of command_state()) * double-quotes are now escaped like the rest of the "bad shell chars" * backticks are now escaped thus preventing "bad `rm -fr /` string" from doing the Wrong Thing (tm) * fixed missing 'listheight' argument in Whiptail.pm and CDialog.pm -- Kevin C. Krinke 0.07 - Mon, 28 Jul 2003 22:45:14 -0400 * mucho-POD-update-o * POD: everything now fits nicely in 80 columns * POD: remove of STATE METHODS section (should exist in UI::Dialog::Backend) * POD: added in word_wrap() entry to UI::Dialog::Backend -- Kevin C. Krinke 0.06 - Mon, 28 Jul 2003 15:41:48 -0400 * updated XDialog with callbacks * tidied up the XDialog POD * UI::Dialog::Backend now depends on Text::Wrap * UI::Dialog::Backend::word_wrap for working with Text::Wrap * _organize_text() now uses $self->word_wrap($cols,'','',@text) * reorganized examples/xdialog.pl * repaired UI::Dialog::Backend::Zenity to use word wrapping correctly * updated debian/control description and depends info -- Kevin C. Krinke 0.05 - Wed, 23 Jul 2003 03:57:33 -0400 * Unforseen bugs with the callback functionality repaired. callback structure finalized * UI::Dialog::Backend::Zenity has been updated to suite the callback changes * examples/zenity.pl has been touched up a bit with error corrections and callback things * UI::Dialog::Backend pod has been updated with the callback functionality details -- Kevin C. Krinke 0.04 - Tue, 22 Jul 2003 03:05:16 -0400 * UI::Dialog::Zenity is considered finished (minus unforseen bugs). * UI::Dialog::Backend provides _per() and _post() to facilitate callback function support * state() now recognizes exit value 129 as cancel * state() returns "UNKNOWN(#)" for unrecognized exit values. * added _esc_text() to prevent odd shell interpretations... * _merge_attrs() escapes all appropriate strings with _esc_text() (including lists) * _organize_text() chomps on last newline. * lots of POD updates, mainly for finializing UI::Dialog::Backend::Zenity. * updated cdialog supported version list with 20030720 release. * Backend::Zenity supports the 'display', 'name', and 'class' GTK options * Backend::Zenity->_is_version() created to handle STDERR issues * Backend::Zenity integrated with _pre() and _post() facilities * Backend::Zenity->calendar() defaults to a date-format of '%d/%m/%y' * Backend::Zenity->gauge_start() uses _pre() and _post() * Backend::Zenity->gauge_end() renamed to gauge_stop() * Backend::Zenity->gauge_stop() uses only _post() * Backend::Zenity pod should be the guideline for all other backends -- Kevin C. Krinke 0.03 - Wed, 16 Jul 2003 03:05:05 -0400 * Backend->fselect() and Backend->dselect() errors resolved * ASCII->password() now interprets BS, DELETE and ^H as a deletion of the last character * Cleanup of various example scripts * implemented _beep() and _clear() * cleanup some code indentation * Whiptail and CDialog now support gauge_text() * GDialog no longer supports gauge_*() at all (gdialog is very flaky in some areas) * debian package now installs examples using dh_installexamples * All backends now support most (if not all) available command line arguments * XDialog's options now support both hyphenated and non-hyphenated forms (ie: 'item-help' and 'itemhelp' are the same option) * CDialog now supports the environment variable DIALOGRC * updated the debian/control long description * override command_*() for Zenity to ignore STDERR. Zenity currently outputs user data to STDERR which get's messed up with GTK warnings if the user's theme is bad. I've sent a patch upstream to Glynn Foster fixing this issue. (The patch simply changes the g_printerr() to g_print() where appropriate.) * added more debug messages of level 2 * implemented UI::Dialog::Backend::XOSD -- Kevin C. Krinke 0.02 - Fri, 27 Jun 2003 09:02:41 -0400 * ->rv($rv||'null') bugfix for state() inconsistencies * repaired Backend::CDialog->checklist() return structure -- Kevin C. Krinke 0.01 - Mon, 16 Jun 2003 00:23:31 -0400 * Initial Release * Extrapolated from UPDM -- Kevin C. Krinke UI-Dialog-1.09/CONTRIBUTORS000644 000765 000024 00000000302 12202472000 015400 0ustar00onest8staff000000 000000 Jeroen Bulten (bugreports, FreeBSD testing) Julian Gilbey (Patches, bugreports, feature requests) Alfonso E.M. (bugreports) UI-Dialog-1.09/COPYRIGHT000644 000765 000024 00000063650 12201404605 015037 0ustar00onest8staff000000 000000 GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. ^L Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. ^L GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. ^L Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. ^L 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. ^L 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. ^L 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. ^L 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ^L How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 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 Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! UI-Dialog-1.09/examples/000755 000765 000024 00000000000 12204450136 015353 5ustar00onest8staff000000 000000 UI-Dialog-1.09/lib/000755 000765 000024 00000000000 12204450136 014303 5ustar00onest8staff000000 000000 UI-Dialog-1.09/Makefile.PL000644 000765 000024 00000006570 12202472000 015507 0ustar00onest8staff000000 000000 use 5.006; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'UI::Dialog', 'VERSION_FROM' => 'lib/UI/Dialog.pm', # finds $VERSION 'PREREQ_PM' => { Text::Wrap => 0 }, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 ( #ABSTRACT_FROM => 'lib/UI/Dialog.pm', # retrieve abstract from module AUTHOR => 'Kevin C. Krinke ') : () ), 'PM_FILTER' => 'perl -pe "s!\\Q/usr/bin/perl\\E!$(FULLPERL)!g"', 'PM' => { 'lib/UI/Dialog.pm' => '$(INST_LIBDIR)/Dialog.pm', 'lib/UI/Dialog/Console.pm' => '$(INST_LIBDIR)/Dialog/Console.pm', 'lib/UI/Dialog/Gauged.pm' => '$(INST_LIBDIR)/Dialog/Gauged.pm', 'lib/UI/Dialog/GNOME.pm' => '$(INST_LIBDIR)/Dialog/GNOME.pm', 'lib/UI/Dialog/KDE.pm' => '$(INST_LIBDIR)/Dialog/KDE.pm', 'lib/UI/Dialog/Backend.pm' => '$(INST_LIBDIR)/Dialog/Backend.pm', 'lib/UI/Dialog/Backend/ASCII.pm' => '$(INST_LIBDIR)/Dialog/Backend/ASCII.pm', 'lib/UI/Dialog/Backend/CDialog.pm' => '$(INST_LIBDIR)/Dialog/Backend/CDialog.pm', 'lib/UI/Dialog/Backend/GDialog.pm' => '$(INST_LIBDIR)/Dialog/Backend/GDialog.pm', 'lib/UI/Dialog/Backend/KDialog.pm' => '$(INST_LIBDIR)/Dialog/Backend/KDialog.pm', 'lib/UI/Dialog/Backend/Nautilus.pm' => '$(INST_LIBDIR)/Dialog/Backend/Nautilus.pm', 'lib/UI/Dialog/Backend/Whiptail.pm' => '$(INST_LIBDIR)/Dialog/Backend/Whiptail.pm', 'lib/UI/Dialog/Backend/XDialog.pm' => '$(INST_LIBDIR)/Dialog/Backend/XDialog.pm', 'lib/UI/Dialog/Backend/XOSD.pm' => '$(INST_LIBDIR)/Dialog/Backend/XOSD.pm', 'lib/UI/Dialog/Backend/Zenity.pm' => '$(INST_LIBDIR)/Dialog/Backend/Zenity.pm', 'lib/UI/Dialog/Screen/Menu.pm' => '$(INST_LIBDIR)/Dialog/Screen/Menu.pm', 'lib/UI/Dialog.pod' => '$(INST_LIBDIR)/Dialog.pod', 'lib/UI/Dialog/Console.pod' => '$(INST_LIBDIR)/Dialog/Console.pod', 'lib/UI/Dialog/Gauged.pod' => '$(INST_LIBDIR)/Dialog/Gauged.pod', 'lib/UI/Dialog/GNOME.pod' => '$(INST_LIBDIR)/Dialog/GNOME.pod', 'lib/UI/Dialog/KDE.pod' => '$(INST_LIBDIR)/Dialog/KDE.pod', 'lib/UI/Dialog/Backend.pod' => '$(INST_LIBDIR)/Dialog/Backend.pod', 'lib/UI/Dialog/Backend/ASCII.pod' => '$(INST_LIBDIR)/Dialog/Backend/ASCII.pod', 'lib/UI/Dialog/Backend/CDialog.pod' => '$(INST_LIBDIR)/Dialog/Backend/CDialog.pod', 'lib/UI/Dialog/Backend/GDialog.pod' => '$(INST_LIBDIR)/Dialog/Backend/GDialog.pod', 'lib/UI/Dialog/Backend/KDialog.pod' => '$(INST_LIBDIR)/Dialog/Backend/KDialog.pod', 'lib/UI/Dialog/Backend/Nautilus.pod' => '$(INST_LIBDIR)/Dialog/Backend/Nautilus.pod', 'lib/UI/Dialog/Backend/Whiptail.pod' => '$(INST_LIBDIR)/Dialog/Backend/Whiptail.pod', 'lib/UI/Dialog/Backend/XDialog.pod' => '$(INST_LIBDIR)/Dialog/Backend/XDialog.pod', 'lib/UI/Dialog/Backend/XOSD.pod' => '$(INST_LIBDIR)/Dialog/Backend/XOSD.pod', 'lib/UI/Dialog/Backend/Zenity.pod' => '$(INST_LIBDIR)/Dialog/Backend/Zenity.pod', 'lib/UI/Dialog/Screen/Menu.pod' => '$(INST_LIBDIR)/Dialog/Screen/Menu.pod', } ); UI-Dialog-1.09/MANIFEST000644 000765 000024 00000003330 12202472000 014655 0ustar00onest8staff000000 000000 Changes CONTRIBUTORS COPYRIGHT examples/ascii.pl examples/cdialog.pl examples/console.pl examples/gdialog.pl examples/gnome.pl examples/kde.pl examples/kdialog.pl examples/nautilus.pl examples/screen-menu.pl examples/ui-dialog.pl examples/whiptail.pl examples/xdialog.pl examples/xosd.pl examples/zenity.pl lib/UI/Dialog.pm lib/UI/Dialog.pod lib/UI/Dialog/Backend.pm lib/UI/Dialog/Backend.pod lib/UI/Dialog/Backend/ASCII.pm lib/UI/Dialog/Backend/ASCII.pod lib/UI/Dialog/Backend/CDialog.pm lib/UI/Dialog/Backend/CDialog.pod lib/UI/Dialog/Backend/GDialog.pm lib/UI/Dialog/Backend/GDialog.pod lib/UI/Dialog/Backend/KDialog.pm lib/UI/Dialog/Backend/KDialog.pod lib/UI/Dialog/Backend/Nautilus.pm lib/UI/Dialog/Backend/Nautilus.pod lib/UI/Dialog/Backend/Whiptail.pm lib/UI/Dialog/Backend/Whiptail.pod lib/UI/Dialog/Backend/XDialog.pm lib/UI/Dialog/Backend/XDialog.pod lib/UI/Dialog/Backend/XOSD.pm lib/UI/Dialog/Backend/XOSD.pod lib/UI/Dialog/Backend/Zenity.pm lib/UI/Dialog/Backend/Zenity.pod lib/UI/Dialog/Charts.pod lib/UI/Dialog/Console.pm lib/UI/Dialog/Console.pod lib/UI/Dialog/Gauged.pm lib/UI/Dialog/Gauged.pod lib/UI/Dialog/GNOME.pm lib/UI/Dialog/GNOME.pod lib/UI/Dialog/KDE.pm lib/UI/Dialog/KDE.pod lib/UI/Dialog/Screen/Menu.pm lib/UI/Dialog/Screen/Menu.pod Makefile.PL MANIFEST This list of files META.yml Module meta-data (added by MakeMaker) README t/UI-Dialog-Backend-ASCII.t t/UI-Dialog-Backend-CDialog.t t/UI-Dialog-Backend-GDialog.t t/UI-Dialog-Backend-KDialog.t t/UI-Dialog-Backend-Nautilus.t t/UI-Dialog-Backend-Whiptail.t t/UI-Dialog-Backend-XDialog.t t/UI-Dialog-Backend-XOSD.t t/UI-Dialog-Backend-Zenity.t t/UI-Dialog-Console.t t/UI-Dialog-Gauged.t t/UI-Dialog-GNOME.t t/UI-Dialog-KDE.t t/UI-Dialog-Screen-Menu.t t/UI-Dialog.t TODO UI-Dialog-1.09/META.yml000644 000765 000024 00000001006 12204450137 015004 0ustar00onest8staff000000 000000 --- #YAML:1.0 name: UI-Dialog version: 1.09 abstract: ~ author: - Kevin C. Krinke license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Text::Wrap: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 UI-Dialog-1.09/README000644 000765 000024 00000004711 12202472000 014410 0ustar00onest8staff000000 000000 UI-Dialog ========= UI::Dialog is a OOPerl wrapper for the various dialog applications. These dialog backends are currently supported: Zenity, GDialog, XDialog, 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. 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. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install PROVIDES This module provides these classes, each with it's own perldoc: UI::Dialog 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 UI::Dialog::Console UI::Dialog::GNOME UI::Dialog::KDE UI::Dialog::Screen::Menu COPYRIGHT AND LICENCE Copyright (C) 2013 Kevin C. Krinke 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 UI-Dialog-1.09/t/000755 000765 000024 00000000000 12204450136 014000 5ustar00onest8staff000000 000000 UI-Dialog-1.09/TODO000644 000765 000024 00000000121 12202472000 014207 0ustar00onest8staff000000 000000 o [anyone] Support a taint mode? * somehow provide a taint-compatible mode? UI-Dialog-1.09/t/UI-Dialog-Backend-ASCII.t000644 000765 000024 00000001563 12201404605 020054 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( tests => 4 ); BEGIN { use_ok( 'UI::Dialog::Backend::ASCII' ); } require_ok( 'UI::Dialog::Backend::ASCII' ); ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $obj = UI::Dialog::Backend::ASCII->new(); isa_ok( $obj, 'UI::Dialog::Backend::ASCII' ); my @methods = qw( new state ra rs rv beep clear yesno msgbox inputbox password textbox menu checklist radiolist fselect dselect spinner draw_gauge end_gauge ); can_ok( 'UI::Dialog::Backend::ASCII', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-CDialog.t000644 000765 000024 00000002047 12201404605 020524 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::CDialog' ); } # require_ok( 'UI::Dialog::Backend::CDialog' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::CDialog->new(); # isa_ok( $obj, 'UI::Dialog::Backend::CDialog' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect # gauge_start gauge_inc gauge_dec gauge_set # gauge_text gauge_stop ); # can_ok( 'UI::Dialog::Backend::CDialog', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-GDialog.t000644 000765 000024 00000001677 12201404605 020540 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::GDialog' ); } # require_ok( 'UI::Dialog::Backend::GDialog' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::GDialog->new(); # isa_ok( $obj, 'UI::Dialog::Backend::GDialog' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect ); # can_ok( 'UI::Dialog::Backend::GDialog', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-KDialog.t000644 000765 000024 00000002136 12201404605 020533 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::KDialog' ); } # require_ok( 'UI::Dialog::Backend::KDialog' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::KDialog->new(); # isa_ok( $obj, 'UI::Dialog::Backend::KDialog' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # msgbox inputbox password textbox menu checklist radiolist # yesno yesnocancel warningyesno warningyesnocancel # fselect getopenfilename getsavefilename getopenurl getsaveurl # dselect getexistingdirectory ); # can_ok( 'UI::Dialog::Backend::KDialog', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-Nautilus.t000644 000765 000024 00000001512 12201404605 021022 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::Nautilus' ); } # require_ok( 'UI::Dialog::Backend::Nautilus' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::Nautilus->new(); # isa_ok( $obj, 'UI::Dialog::Backend::Nautilus' ); # my @methods = qw( path paths uri uris geometry uri_unescape ); # can_ok( 'UI::Dialog::Backend::Nautilus', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-Whiptail.t000644 000765 000024 00000001704 12201404605 021002 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::Whiptail' ); } # require_ok( 'UI::Dialog::Backend::Whiptail' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::Whiptail->new(); # isa_ok( $obj, 'UI::Dialog::Backend::Whiptail' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect ); # can_ok( 'UI::Dialog::Backend::Whiptail', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-XDialog.t000644 000765 000024 00000002716 12201404605 020554 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::XDialog' ); } # require_ok( 'UI::Dialog::Backend::XDialog' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::XDialog->new(); # isa_ok( $obj, 'UI::Dialog::Backend::XDialog' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect # _del_progress _del_gauge _mk_cmnd state combobox # rangebox rangesbox2 rangesbox3 spinbox spinsbox2 # spinsbox3 buildlist treeview calendar timebox # inputsbox2 inputsbox3 passwords2 passwords3 # msgbox infobox textbox editbox logbox tailbox # progress_start progress_inc progress_dec # progress_set progress_stop gauge_start gauge_inc # gauge_dec gauge_set gauge_text gauge_stop ); # can_ok( 'UI::Dialog::Backend::XDialog', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-XOSD.t000644 000765 000024 00000001630 12201404605 017774 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::XOSD' ); } # require_ok( 'UI::Dialog::Backend::XOSD' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::XOSD->new(); # isa_ok( $obj, 'UI::Dialog::Backend::XOSD' ); # my @methods = qw( new _del_display _gen_opt_str line file gauge # display_start display_text display_gauge # display_stop ); # can_ok( 'UI::Dialog::Backend::XOSD', @methods ); UI-Dialog-1.09/t/UI-Dialog-Backend-Zenity.t000644 000765 000024 00000002361 12201404605 020503 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Backend::Zenity' ); } # require_ok( 'UI::Dialog::Backend::Zenity' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Backend::Zenity->new(); # isa_ok( $obj, 'UI::Dialog::Backend::Zenity' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect # _del_gauge _mk_cmnd _is_version # command_state command_string command_array # question entry info error warning text_info # editbox list calendar gauge_start gauge_inc # gauge_dec gauge_set gauge_text gauge_stop # ); # can_ok( 'UI::Dialog::Backend::Zenity', @methods ); UI-Dialog-1.09/t/UI-Dialog-Console.t000644 000765 000024 00000001622 12201404605 017275 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Console' ); } # require_ok( 'UI::Dialog::Console' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Console->new(); # isa_ok( $obj, 'UI::Dialog::Console' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect ); # can_ok( 'UI::Dialog::Console', @methods ); UI-Dialog-1.09/t/UI-Dialog-Gauged.t000644 000765 000024 00000001765 12201404605 017077 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Gauged' ); } # require_ok( 'UI::Dialog::Gauged' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Gauged->new(); # isa_ok( $obj, 'UI::Dialog::Gauged' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect # gauge_start gauge_stop gauge_inc gauge_dec # gauge_set gauge_text ); # can_ok( 'UI::Dialog::Gauged', @methods ); UI-Dialog-1.09/t/UI-Dialog-GNOME.t000644 000765 000024 00000001610 12201404605 016535 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::GNOME' ); } # require_ok( 'UI::Dialog::GNOME' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::GNOME->new(); # isa_ok( $obj, 'UI::Dialog::GNOME' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect ); # can_ok( 'UI::Dialog::GNOME', @methods ); UI-Dialog-1.09/t/UI-Dialog-KDE.t000644 000765 000024 00000001576 12201404605 016306 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::KDE' ); } # require_ok( 'UI::Dialog::KDE' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::KDE->new(); # isa_ok( $obj, 'UI::Dialog::KDE' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect ); # can_ok( 'UI::Dialog::KDE', @methods ); UI-Dialog-1.09/t/UI-Dialog-Screen-Menu.t000644 000765 000024 00000001612 12202472000 020006 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog::Screen::Menu' ); } # require_ok( 'UI::Dialog::Screen::Menu' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog::Screen::Menu->new(); # isa_ok( $obj, 'UI::Dialog::Screen::Menu' ); # my @methods = qw( new run loop is_looping break_loop # add_menu_item get_menu_items del_menu_item set_menu_item # ); # can_ok( 'UI::Dialog::Screen::Menu', @methods ); UI-Dialog-1.09/t/UI-Dialog.t000644 000765 000024 00000001545 12201404605 015701 0ustar00onest8staff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More ( skip_all => "Skipped until better tests are written." ); # use Test::More ( tests => 4 ); # BEGIN { use_ok( 'UI::Dialog' ); } # require_ok( 'UI::Dialog' ); # ######################### # # Insert your test code below, the Test::More module is use()ed here so read # # its man page ( perldoc Test::More ) for help writing this test script. # my $obj = UI::Dialog->new(); # isa_ok( $obj, 'UI::Dialog' ); # my @methods = qw( new state ra rs rv nautilus xosd beep clear # yesno msgbox inputbox password textbox menu # checklist radiolist fselect dselect ); # can_ok( 'UI::Dialog', @methods ); UI-Dialog-1.09/lib/UI/000755 000765 000024 00000000000 12204450136 014620 5ustar00onest8staff000000 000000 UI-Dialog-1.09/lib/UI/Dialog/000755 000765 000024 00000000000 12204450136 016017 5ustar00onest8staff000000 000000 UI-Dialog-1.09/lib/UI/Dialog.pm000644 000765 000024 00000044751 12202472000 016360 0ustar00onest8staff000000 000000 package UI::Dialog; ############################################################################### # Copyright (C) 2013 Kevin C. Krinke # # 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 Carp; BEGIN { use vars qw($VERSION); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}; 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 =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 =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 (0) =item B (as indicated) =item B (as indicated) =item B ('') * =item B ('') * =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 =back =head1 STATE METHODS =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =head1 WIDGET METHODS =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =over 2 =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 =back =head1 SEE ALSO =item PERLDOC =over 2 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 =item MAN FILES =over 2 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) 2013 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 �����������������������UI-Dialog-1.09/lib/UI/Dialog.pod��������������������������������������������������������������������000644 �000765 �000024 �00000023157 12202472000 016523� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog =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) * =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 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) 2013 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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/���������������������������������������������������������������000755 �000765 �000024 �00000000000 12204450136 017346� 5����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend.pm�������������������������������������������������������������000644 �000765 �000024 �00000046502 12202472000 017703� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend; ############################################################################### # Copyright (C) 2013 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 Carp; use Cwd qw( abs_path ); use File::Basename; use Text::Wrap qw( wrap ); BEGIN { use vars qw($VERSION); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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 }; bless($self, $class); return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Accessory Methods #: #: 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'}); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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(); $self->_debug((join(" | ",(caller())))." > ra() > rset: ".((@_) ? "@_" : 'NULL'),3); $self->{'_state'}->{'ra'} = ($_[0] =~ /^null$/i) ? [ 0 ] : [ @_ ] unless not @_; my $aref = $self->{'_state'}->{'ra'}; ref($aref) eq "ARRAY" or $aref = []; return(@{$aref}); } #: return the last response data as a SCALAR sub rs { my $self = shift(); my $rset = $_[0]; $self->_debug((join(" | ",(caller())))." > rs() > rset: ".(($rset) ? $rset : 'NULL'),3); $self->{'_state'}->{'rs'} = ($rset =~ /^null$/i) ? 0 : $rset unless not $rset; return($self->{'_state'}->{'rs'}); } #: return the last exit code as a SCALAR sub rv { my $self = shift(); my $rset = $_[0]; $self->_debug((join(" | ",(caller())))." > rv() > rset: ".(($rset) ? $rset : 'NULL'),3); $self->{'_state'}->{'rv'} = ($rset =~ /^null$/i) ? '0' : $rset unless not $rset; 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.")"); } } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Execution Methods #: #: execute a simple command (return the exit code only); sub command_state { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("command: ".$cmnd,1); system($cmnd . " 2>&1 > /dev/null"); my $rv = $? >> 8; $self->_debug("command rv: ".$rv,2); return($rv); } #: execute a command and return the exit code and one-line SCALAR sub command_string { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("command: ".$cmnd,1); chomp(my $text = `$cmnd 2>&1`); my $rv = $? >> 8; $self->_debug("command rs: ".$rv." '".$text."'",2); 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]; $self->_debug("command: ".$cmnd,1); chomp(my $text = `$cmnd 2>&1`); my $rv = $? >> 8; $self->_debug("command ra: ".$rv." '".$text."'",2); return([split(/\n/,$text)]) unless defined wantarray; return (wantarray) ? ($rv,[split(/\n/,$text)]) : [split(/\n/,$text)]; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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; my @strings = wrap($indent, $sub_indent, @_); return(@strings); } # 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 $path = $args->{'path'}; if (!$path || $path =~ /^(\.|\.\/)$/) { $path = $cwd; } my $file; 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); $file = $self->menu(height=>$args->{'height'},width=>$args->{'width'},listheight=>($args->{'listheight'}||$args->{'menuheight'}), title=>$args->{'title'},text=>$path,list=>$menu); if ($self->state() eq "CANCEL") { $self->rv(1); $self->rs('NULL'); $self->ra('NULL'); last FSEL; } elsif ($file ne "") { if ($list->[($file - 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.' already exists! Choose another name please.'); } } $file = $path."/".$nfn; $file =~ s!/$!! unless $file =~ m!^/$!; $file =~ s!/\./!/!g; $file =~ s!/+!/!g; last FSEL; } elsif ($list->[($file - 1 || 0)] eq "../") { $path = dirname($path); } elsif ($list->[($file - 1 || 0)] eq "./") { $file = $path; $file =~ s!/$!! unless $file =~ m!^/$!; $file =~ s!/\./!/!g; $file =~ s!/+!/!g; last FSEL; } elsif (-d $path."/".$list->[($file - 1 || 0)]) { $path = $path."/".$list->[($file - 1 || 0)]; } elsif (-e $path."/".$list->[($file - 1 || 0)]) { $file = $path."/".$list->[($file - 1 || 0)]; $file =~ s!/$!! unless $file =~ m!^/$!; $file =~ s!/\./!/!g; $file =~ s!/+!/!g; last FSEL; } } $file = 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($file); return($file); } } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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); } #: 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)) { $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'} : ""); if ($args->{'title'} && length($args->{'title'})) { $args->{'title'} = $self->_esc_text($args->{'title'}); } if ($args->{'backtitle'} && length($args->{'backtitle'})) { $args->{'backtitle'} = $self->_esc_text($args->{'backtitle'}); } # if ($args->{'text'} && length($args->{'text'})) { # my $text = $args->{'text'}; # if (ref($text) eq "ARRAY") { # $args->{'text'} = $self->_esc_text_array($args->{'text'}); # } else { # $args->{'text'} = $self->_esc_text($args->{'text'}); # } # } if ($args->{'list'} && length($args->{'list'})) { my $list = $args->{'list'}; if (ref($list) eq "ARRAY") { my $total = @{$list}; for (my $i = 0; $i < $total; $i++) { my $elem = $list->[$i]; if (ref($elem) eq "ARRAY") { my $elem_total = @{$elem}; for (my $j = 0; $j < $elem_total; $j++) { $elem->[$j] = $self->_esc_text($elem->[$j]); } } else { $list->[$i] = $self->_esc_text($list->[$i]); } } } else { $args->{'list'} = $self->_esc_text($args->{'list'}); } } $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 =~ s!\\Z[0-7bBuUrRn]!!gmi; $text =~ s!\[[AC]=\w+\]!!gmi; $text =~ s!\[/?[BURN]\]!!gmi; return($text); } sub _esc_text { my $self = $_[0]; my $text = $_[1]; unless (ref($text)) { $text =~ s!\"!\\"!gm; $text =~ s!\`!\\`!gm; $text =~ s!\(!\(!gm; $text =~ s!\)!\)!gm; $text =~ s!\[!\[!gm; $text =~ s!\]!\]!gm; $text =~ s!\{!\{!gm; $text =~ s!\}!\}!gm; $text =~ s!\$!\\\$!gm; $text =~ s!\>!\>!gm; $text =~ s!\<!\<!gm; } return($text); } #: indent and organize the text argument sub _organize_text { my $self = $_[0]; my $text = $_[1] || return(); my $width = $_[2] || 65; 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++) { $array[$i] = $self->_esc_text($array[$i]); } if ($self->{'scale'}) { foreach my $line (@array) { my $s_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; 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); $pad = (($self->{'_opts'}->{'width'} - 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)); $pad = (($self->{'_opts'}->{'width'}) - length($s_line)); } } if ($pad) { $text .= (" " x $pad).$line."\n"; } else { $text .= $line."\n"; } } $text = $self->_strip_text($text); chomp($text); 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 (@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."/"); } 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; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend.pod������������������������������������������������������������000644 �000765 �000024 �00000041352 12202472000 020047� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend =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 =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) 2013 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 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Charts.pod�������������������������������������������������������������000644 �000765 �000024 �00000016632 12201404605 017754� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Charts =head1 SYNOPSIS This Perl Document details, the various attributes, widgets and all the dialog variant-specific features made avaiable by UI::Dialog and the specific UI::Dialog::Backend:: modules. This document is not complete and at this time serves only as a quick reference for the standard functions, attributes and of course the widget chart. =head1 STANDARD ATTRIBUTES These can be used during object construction (as defaults) or with any widget method call (override default). title => "string" backtitle => "string" height => 20 #characters, not pixels width => 65 # '' " '' listheight => 5 # '' " '' menu => [ 't1', 't1 desc', 't2', 't2 desc' ] list => [ 't1', [ 't1 desc', 1 ], 't2', [ 't2 desc'. 0 ] ] beepbefore => 0 beepafter => 0 autoclear => 0 =head2 STANDARD ATTRIBUTE NOTES 'autoclear' is only works in terminals and consoles (doesn't do anything for any of the GUI backends. 'menu' is only used with the menu() widget and 'list' is used for checklist() and radiolist() widgets. =head1 META CLASSES The following list of classes are the "wrappers" that perform a few simple tests that determine a suitable dialog variant to use. These allow the end- progammer to create an application using the standard widgets without having to force the end-user into any particular UI::Dialog::Backend::. End-users can override the meta-class via the environment variables listed further in this document. This list makes references to the DISPLAY environment variable as well as to running in a CONSOLE (terminal, xterm, etc). The DISPLAY environment variable is not null when being run within an X-Windows session. =over 4 =item UI::Dialog (most flexible) ::Backend:: (if DISPLAY != "") Zenity, XDialog, GDialog, KDialog (if DISPLAY == "") CDialog, Whiptail, ASCII =item UI::Dialog::GNOME (GNOME oriented) ::Backend:: (assumes DISPLAY) Zenity, XDialog, GDialog =item UI::Dialog::KDE (KDE oriented) ::Backend:: (assumed DISPLAY) KDialog, XDialog =item UI::Dialog::Console (non-GUI only) ::Backend:: (assumed CONSOLE) CDialog, Whiptail, ASCII =item UI::Dialog::Gauged (flexible, has gauge methods) ::Backend:: (if DISPLAY != "") Zenity, XDialog (if DISPLAY == "") CDialog, Whiptail =back =head1 STANDARD WIDGETS These widgets are provided by all backends and are the only methods made available by all meta classes. $switch = $d->yesno( text => 'A question?' ); $switch = $d->msgbox( text => 'A message.' ); $scalar = $d->inputbox( text => 'Type visible text.' ); $scalar = $d->password( text => 'Type hidden text.' ); $switch = $d->textbox( filename => '/path/to/regular/file' ); $scalar = $d->fselect( path => '/path/to/start/browse' ); $scaler = $d->dselect( path => '/path/to/start/browse' ); $scalar = $d->menu( text => 'A message.', menu => [ 't1', 't1 desc', 't2', 't2 desc' ] ); $scalar = $d->radiolist( text => 'A message.', list => [ 't1', [ 't1 desc', 1 ], 't2', [ 't2 desc', 0 ] ] ); @array = $d->checklist( text => 'A message.', list => [ 't1', [ 't1 desc', 1 ], 't2', [ 't2 desc', 0 ] ] ); =head1 COMPLETE WIDGET CHART -----------------------------------+ Zenity \ ---------------------------------+ \ XDialog \ \ -------------------------------+ \ \ Whiptail \ \ \ -----------------------------+ \ \ \ KDialog \ \ \ \ ---------------------------+ \ \ \ \ GDialog \ \ \ \ \ -------------------------+ \ \ \ \ \ CDialog \ \ \ \ \ \ -----------------------+ \ \ \ \ \ \ ASCII \ \ \ \ \ \ \ ---------------------+ \ \ \ \ \ \ \ Widget Method Name \ \ \ \ \ \ \ \ -----------------------+---+---+---+---+---+---+---+ calendar | | C | | | | X | Z | checklist | A | C | G | K | W | X | Z | combobox | | | | | | X | | draw_gauge | A | | | | | | | dselect | A | C | G | K | W | X | Z | editbox | | | | | | X | Z | end_gauge | A | | | | | | | entry | | | | | | | Z | error | | | | K | | | Z | fselect | A | C | G | K | W | X | Z | gauge_dec | | C | | | W | X | Z | gauge_inc | | C | | | W | X | Z | gauge_set | | C | | | W | X | Z | gauge_start | | C | | | W | X | Z | gauge_stop | | C | | | W | X | Z | gauge_text | | C | | | W | X | Z | getexistingdirectory | | | | K | | | | getopenfilename | | | | K | | | | getopenurl | | | | K | | | | getsavefilename | | | | K | | | | getsaveurl | | | | K | | | | info | | | | | | | Z | infobox | A | C | G | | W | X | | inputbox | A | C | G | K | W | X | Z | inputsbox2 | | | | | | X | | inputsbox3 | | | | | | X | | list | | | | | | X | | logbox | | | | | | | Z | menu | | | | | | X | | msgbox | A | C | G | K | W | X | Z | noyes | | | | K | | | Z | password | A | C | | K | W | X | Z | passwords2 | | | | | | X | | passwords3 | | | | | | X | | progress_dec | | | | | | X | | progress_inc | | | | | | X | | progress_set | | | | | | X | | progress_start | | | | | | X | | progress_stop | | | | | | X | | question | | | | | | | Z | radiolist | A | C | G | K | W | X | Z | rangebox | | | | | | X | | rangesbox2 | | | | | | X | | rangesbox3 | | | | | | X | | sorry | | | | K | | | | spinbox | | | | | | X | | spinner | | | | | | X | | spinsbox2 | | | | | | X | | spinsbox3 | | | | | | X | | tailbox | | C | | | | X | | tailboxbg | | C | | | | | | text_info | | | | | | | Z | textbox | A | C | G | K | W | X | Z | timebox | | C | | | | X | | treeview | | | | | | X | | warning | | | | | | | Z | warningyesno | | | | K | | | | warningyesnocancel | | | | K | | | | yesno | A | C | G | K | W | X | Z | yesnocancel | | | | K | | | | =cut ������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Console.pm�������������������������������������������������������������000644 �000765 �000024 �00000010106 12202472000 017745� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Console; ############################################################################### # Copyright (C) 2013 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 Carp; use UI::Dialog; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}; 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; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Console.pod������������������������������������������������������������000644 �000765 �000024 �00000005711 12202472000 020121� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Console =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) 2013 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 �������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Gauged.pm��������������������������������������������������������������000644 �000765 �000024 �00000016550 12202472000 017550� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Gauged; ############################################################################### # Copyright (C) 2013 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 Carp; BEGIN { use vars qw($VERSION); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}; 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; ��������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Gauged.pod�������������������������������������������������������������000644 �000765 �000024 �00000011611 12202472000 017707� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Gauged =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) 2013 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 �����������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/GNOME.pm���������������������������������������������������������������000644 �000765 �000024 �00000007531 12202472000 017220� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::GNOME; ############################################################################### # Copyright (C) 2013 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 Carp; use UI::Dialog; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}; 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; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/GNOME.pod��������������������������������������������������������������000644 �000765 �000024 �00000007466 12202472000 017375� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::GNOME =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) 2013 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/KDE.pm�����������������������������������������������������������������000644 �000765 �000024 �00000006560 12202472000 016757� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::KDE; ############################################################################### # Copyright (C) 2013 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 Carp; use UI::Dialog; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}; 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; ������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/KDE.pod����������������������������������������������������������������000644 �000765 �000024 �00000006015 12202472000 017120� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::KDE =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) 2013 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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Screen/����������������������������������������������������������������000755 �000765 �000024 �00000000000 12204450136 017236� 5����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Screen/Menu.pm���������������������������������������������������������000644 �000765 �000024 �00000010502 12202472000 020466� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Screen::Menu; use strict; use warnings; use diagnostics; use constant { TRUE => 1, FALSE => 0 }; BEGIN { use vars qw($VERSION); $VERSION = '1.09'; } 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, ); } 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Screen/Menu.pod��������������������������������������������������������000644 �000765 �000024 �00000021340 12202472000 020636� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Screen::Menu =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::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) 2013 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/ASCII.pm�������������������������������������������������������000644 �000765 �000024 �00000105204 12202472000 020526� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::ASCII; ############################################################################### # Copyright (C) 2013 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 Carp; use UI::Dialog::Backend; use Time::HiRes qw( sleep ); BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.09'; } $| = 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->{'_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 = $self->_organize_text($cfg->{'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 = $self->_organize_text($cfg->{'text'}) || " "; my $backtitle = $cfg->{'backtitle'} || " "; my $title = $cfg->{'title'} || " "; my $menu = $cfg->{'menu'} || []; my ($help,$cancel,$extra) = $self->_BUTTONS(@_); 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 = $self->_organize_text($cfg->{'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'} = $args->{'list'} if ref($args->{'list'}) eq "ARRAY"; my $string; 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 += 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; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/ASCII.pod������������������������������������������������������000644 �000765 �000024 �00000022442 12202472000 020676� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::ASCII =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) 2013 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/CDialog.pm�����������������������������������������������������000644 �000765 �000024 �00000107007 12202472000 021203� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::CDialog; ############################################################################### # Copyright (C) 2013 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 Config; use FileHandle; use Carp; 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.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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->_determine_dialog_variant(); 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 =~ /-200[3-9]/) { $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 _mk_cmnd { my $self = shift(); my $final = shift(); my $cmnd; my $args = $self->_merge_attrs(@_); $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'; $cmnd = $self->{'_opts'}->{'bin'}; $cmnd .= ' --title "' . ($args->{'title'} || $self->{'_opts'}->{'title'}) . '"' unless not $args->{'title'} and not $self->{'_opts'}->{'title'}; $cmnd .= ' --backtitle "' . ($args->{'backtitle'} || $self->{'_opts'}->{'backtitle'}) . '"' unless not $args->{'backtitle'} and not $self->{'_opts'}->{'backtitle'}; $cmnd .= ' --separate-output' unless $self->{'_opts'}->{'force-no-separate-output'} or (not $args->{'separate-output'} and not $self->{'_opts'}->{'separate-output'}); if ($self->is_cdialog()) { $cmnd .= ' --colors'; $cmnd .= ' --cr-wrap'; # --begin <x> <y> my $begin = $args->{'begin'}; if (ref($begin) eq "ARRAY") { $cmnd .= ' --begin '.$begin->[0].' '.$begin->[1]; } $cmnd .= ' --cancel-label "'.$args->{'cancel-label'}.'"' unless not $args->{'cancel-label'}; $cmnd .= ' --defaultno' unless not $args->{'defaultno'}; $cmnd .= ' --default-item "'.$args->{'default-item'}.'"' unless not $args->{'default-item'}; $cmnd .= ' --exit-label "'.$args->{'exit-label'}.'"' unless not $args->{'exit-label'}; $cmnd .= ' --extra-button' unless not $args->{'extra-button'} and not $args->{'extra-label'}; $cmnd .= ' --extra-label "'.$args->{'extra-label'}.'"' unless not $args->{'extra-label'}; $cmnd .= ' --help-button' unless not $args->{'help-button'} and not $args->{'help-label'}; $cmnd .= ' --help-label "'.$args->{'help-label'}.'"' unless not $args->{'help-label'}; $cmnd .= ' --max-input "'.$args->{'max-input'}.'"' unless not $args->{'max-input'}; $cmnd .= ' --no-cancel' unless not $args->{'nocancel'} and not $args->{'no-cancel'}; $cmnd .= ' --no-collapse' unless not $args->{'no-collapse'} and not $args->{'literal'}; $cmnd .= ' --no-shadow' unless not $args->{'no-shadow'}; $cmnd .= ' --ok-label "'.$args->{'ok-label'}.'"' unless not $args->{'ok-label'}; $cmnd .= ' --shadow' unless not $args->{'shadow'}; $cmnd .= ' --tab-correct' unless not $args->{'tab-correct'}; $cmnd .= ' --tab-len "'.$args->{'tab-len'}.'"' unless not $args->{'tab-len'}; $cmnd .= ' --yes-label "'.$args->{'yes-label'}.'"' unless not $args->{'yes-label'}; $cmnd .= ' --no-label "'.$args->{'no-label'}.'"' unless not $args->{'no-label'}; # --item-help #<-- NEEDS WORK # --no-kill #<-- tailboxbg only } $cmnd .= " " . $final; return($cmnd); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Override Inherited Methods #: sub command_state { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("".$cmnd); my $null_dev = $^O =~ /win32/i ? 'NUL:' : '/dev/null'; system($cmnd . " 2> $null_dev"); return($? >> 8); } sub command_string { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug($cmnd); $self->gen_tempfile_name(); # don't accept the first result my $tmpfile = $self->gen_tempfile_name(); my $text; system($cmnd." 2> ".$tmpfile); my $rv = $? >> 8; if (-f $tmpfile # don't assume the file exists && open(WHIPF,"<".$tmpfile)) { local $/; $text = <WHIPF>; close(WHIPF); unlink($tmpfile); } else { $text = ""; } return($text) unless defined wantarray; return (wantarray) ? ($rv,$text) : $text; } sub command_array { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug($cmnd); $self->gen_tempfile_name(); # don't accept the first result my $tmpfile = $self->gen_tempfile_name(); my $text; system($cmnd." 2> ".$tmpfile); my $rv = $? >> 8; if (-f $tmpfile # don't assume the file exists && open(WHIPF,"<".$tmpfile)) { local $/; $text = <WHIPF>; close(WHIPF); unlink($tmpfile); } else { $text = ""; } if ($self->{'_opts'}->{'force-no-separate-output'}) { # a side effect of this forcible backwards compatibility is that any # "tags" with spaces will get broken down. *shrugs* Not much I can # do about this and because it's a minority of users with these # ancient versions of dialog I'm not delving any deeper into it. return([split(/\s/,$text)]) unless defined wantarray; return (wantarray) ? ($rv,[split(/\s/,$text)]) : [split(/\s/,$text)]; } else { return([split("\n",$text)]) unless defined wantarray; return (wantarray) ? ($rv,[split("\n",$text)]) : [split("\n",$text)]; } } sub _organize_text { my $self = $_[0]; my $text = $_[1] || return(); my $width = $_[2] || 65; 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++) { $array[$i] = $self->_esc_text($array[$i]); } if ($self->{'scale'}) { foreach my $line (@array) { my $s_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); # $pad = (($self->{'_opts'}->{'width'} - 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)); # $pad = (($self->{'_opts'}->{'width'}) - length($s_line)); } } if ($pad) { $text .= (" " x $pad).$line.$new_line; } else { $text .= $line . $new_line; } } 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 $command = $self->_mk_cmnd(' --yesno',@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my $rv = $self->command_state($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $self->rv($rv); $this_rv = 0; } else { $self->ra("YES"); $self->rs("YES"); $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $cmnd_prefix = ' --inputbox'; if ($args->{'password'}) { $cmnd_prefix = ' --passwordbox'; } my $command = $self->_mk_cmnd($cmnd_prefix,@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'init'}||$args->{'entry'}||'') . '"' unless not $args->{'init'} and not $args->{'entry'}; my ($rv,$text) = $self->command_string($command); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $this_rv = 0; } else { $self->rv('null'); $self->rs($text); $self->ra($text); $this_rv = $text; } $self->_post($args); return($this_rv); } #: 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 $command = $self->_mk_cmnd(' --'.$args->{'msgbox'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my $rv = $self->command_state($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $this_rv = 0; } else { if (($args->{'msgbox'} eq "infobox") && ($args->{'timeout'} || $args->{'wait'})) { my $s = int(($args->{'wait'}) ? $args->{'wait'} : ($args->{'timeout'}) ? ($args->{'timeout'} / 1000.0) : 1.0); sleep($s); } $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_rv); } sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'msgbox','infobox')); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --textbox",@_); $command .= ' "' . ($args->{'path'}||'.') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$text) = $self->command_string($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $this_rv = 0; } else { $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_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,@_); my $command = $self->_mk_cmnd(" --menu",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', ' ' ] unless ref($args->{'list'}) eq "ARRAY"; foreach my $item (@{$args->{'list'}}) { $command .= ' "' . ($item||' ') . '"'; } } else { $args->{'items'} = [ ' ', ' ' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . ($item||' ') . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $this_rv = 0; } else { $self->rv('null'); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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,@_); $self->{'checklist'} ||= 'checklist'; my $command = $self->_mk_cmnd(" --".$self->{'checklist'},@_,'separate-output',1); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.($item||' ').'" "'.($info->[0]||' ').'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . ($item|' ') . '"'; } } my ($rv,$selected) = $self->command_array($command); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->ra('null'); $this_rv = 0; } else { $self->rv('null'); $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a radio button list 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 $command = $self->_mk_cmnd(" --".$self->{'radiolist'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.($item||' ').'" "'.($info->[0]||' ').'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . ($item||' ') . '"'; } } my ($rv,$selected) = $self->command_string($command); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->ra('null'); $self->rs('null'); $this_rv = 0; } else { $self->rv('null'); $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --fselect",@_); $command .= ' "' . ($args->{'path'}||abs_path()) . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$file) = $self->command_string($command); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $this_rv = 0; } else { $self->rv('null'); $self->rs($file); $self->ra($file); $this_rv = $file; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --calendar",@_); $command .= ' "' . ($args->{'text'}||'') . '"'; $command .= ' "' . ($args->{'height'}||'6') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'day'}||'') . '"'; $command .= ' "' . ($args->{'month'}||'') . '"'; $command .= ' "' . ($args->{'year'}||'') . '"'; my ($rv,$date) = $self->command_string($command); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $this_rv = 0; } else { chomp($date); $self->rv('null'); $self->rs($date); $self->ra(split(/\//,$date)); $this_rv = $date; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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); my $command = $self->_mk_cmnd(" --timebox",@_); $command .= ' "' . ($args->{'text'}||'') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'hour'}||$hour) . '"'; $command .= ' "' . ($args->{'minute'}||$min) . '"'; $command .= ' "' . ($args->{'second'}||$sec) . '"'; my ($rv,$time) = $self->command_string($command); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $this_rv = 0; } else { chomp($time); $self->rv('null'); $self->rs($time); $self->ra(split(/\:/,$time)); $this_rv = $time; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --tailbox",@_); $command .= ' "' . ($args->{'path'}||'') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv) = $self->command_state($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $this_rv = 0; } else { $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --tailboxbg",@_); $command .= ' "' . ($args->{'path'}||'') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv) = $self->command_state($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $this_rv = 0; } else { $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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,@_); $self->{'form'} ||= 'form'; my $command = $self->_mk_cmnd(" --".$self->{'form'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'30') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'formheight'}||$args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; # <label1> <l_y1> <l_x1> <item1> <i_y1> <i_x1> <flen1> <ilen1> # [ [ 'label1', 1, 1 ], [ 'item1', 1, 5, 10, 10 ], ... ] $args->{'list'} = [ [ 'bad', 1, 1 ], [ 'list', 1, 5, 4, "0" ] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}) || [ 'bad', 1, 1 ]; $info = shift(@{$args->{'list'}}) || [ 'list', 1, 5, 4, "0" ]; $command .= ' "'.($item->[0]||' ').'" "'.$item->[1].'" "'.$item->[2].'" "'.($info->[0]||' ').'" "'.$info->[1].'" "'.$info->[2].'" "'.$info->[3].'" "'.$info->[4].'"'; } my ($rv,$selected) = $self->command_array($command); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->ra('null'); $this_rv = 0; } else { $self->rv('null'); $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } # #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # #: inputmenu # sub inputmenu { # my $self = shift(); # my $args = $self->_merge_attrs(@_); # $self->_beep($args->{'beepbefore'}); # my ($rv,$list) = (0,($args->{'list'}||$args->{'items'})); # INPUTMENULOOP: while (1) { # my $command = $self->_mk_cmnd(" --inputmenu",@_); # $command .= ' "' . ($args->{'text'}||'') . '"'; # $command .= ' "' . ($args->{'height'}||'20') . '"'; # $command .= ' "' . ($args->{'width'}||'65') . '"'; # $command .= ' "' . ($args->{'list-height'}||'10') . '"'; # $list = [ ' ', ' ' ] unless ref($list) eq "ARRAY"; # foreach my $item (@{$list}) { # $command .= ' "' . ($item||' ') . '"'; # } # ($rv,$list) = $self->command_array($command); # $self->rs('null'); # if ($rv && $rv >= 1) { # $self->rv($rv); # $self->ra('null'); # # return(0); # } else { # $self->rv('null'); # $self->ra($list); # # return($list); # } # use Data::Dumper; # if ($self->state() eq "EXTRA" && $list->[0] =~ /^.*RENAMED\s([+)\s(.+)$/) { # my ($RTag,$RName) = ($1,$2); # my $alt_list = []; # while (@$list) { # my $item = shift(@$list); # my $name = shift(@$list); # if ($item eq $RTag) { # push(@$alt_list,$item,$RName); # } else { # push(@$alt_list,$item,$name); # } # print "$item $name\n"; sleep(1); # } # print Dumper($RTag,$RName,$alt_list); sleep(2); # $list = $alt_list; # next INPUTMENULOOP; # } # last INPUTMENULOOP; # } # $self->_beep($args->{'beepafter'}); # $self->rs('null'); # if ($rv && $rv >= 1) { # $self->rv($rv); # $self->ra('null'); # return(0); # } else { # $self->rv('null'); # $self->ra($list); # return($list); # } # } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --gauge",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($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; 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; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/CDialog.pod����������������������������������������������������000644 �000765 �000024 �00000027100 12202472000 021344� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::CDialog =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) 2013 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/GDialog.pm�����������������������������������������������������000644 �000765 �000024 �00000040214 12202472000 021203� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::GDialog; ############################################################################### # Copyright (C) 2013 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 FileHandle; use Carp; use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}); } 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 _mk_cmnd { my $self = shift(); my $final = shift(); my $cmnd; my $args = $self->_merge_attrs(@_); $cmnd = $args->{'bin'}; $cmnd .= ' --title "' . ($args->{'title'} || $args->{'title'}) . '"' unless not $args->{'title'} and not $args->{'title'}; $cmnd .= ' --backtitle "' . ($args->{'backtitle'} || $args->{'backtitle'}) . '"' unless not $args->{'backtitle'} and not $args->{'backtitle'}; $cmnd .= ' --separate-output' unless not $args->{'separate-output'} and not $args->{'separate-output'}; $cmnd .= " " . $final; return($cmnd); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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 $command = $self->_mk_cmnd(' --yesno',@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my $rv = $self->command_state($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $this_rv = 0; } else { $self->ra("YES"); $self->rs("YES"); $this_rv = 1; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(' --inputbox',@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'init'}||'') . '"' unless not $args->{'init'} and not $args->{'entry'}; my ($rv,$text) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($text); $self->rs($text); $this_rv = $text; } $self->_post($args); return($this_rv); } #: password boxes aren't supported by gdialog sub password { my $self = shift(); $self->msgbox(text=> 'GDialog does not support passwords at all, '. 'you will see the text as you type in the next dialog.' ); return($self->inputbox('caller',((caller(1))[3]||'main'),@_)); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(' --'.$args->{'msgbox'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my $rv = $self->command_state($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } $self->_post($args); return($this_rv); } sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'msgbox','infobox')); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --textbox",@_); $command .= ' "' . ($args->{'path'}||'.') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$text) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($text); $self->rs($text); $this_rv = $text; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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,@_); my $command = $self->_mk_cmnd(" --menu",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', ' ' ] unless ref($args->{'list'}) eq "ARRAY"; foreach my $item (@{$args->{'list'}}) { $command .= ' "' . $item . '"'; } } else { $args->{'items'} = [ ' ', ' ' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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,@_); $self->{'checklist'} ||= 'checklist'; my $command = $self->_mk_cmnd(" --".$self->{'checklist'},@_,'separate-output',1); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 0] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->ra('null'); $this_rv = 0; } else { $self->rs(join("\n",@$selected)); $self->ra(@$selected); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a radio button list 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 $command = $self->_mk_cmnd(" --".$self->{'radiolist'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 0] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # #: progress meter # sub gauge_start { # my $self = shift(); # my $args = $self->_merge_attrs(@_); # return(0) unless not defined $self->{'_GAUGE'}; # $self->_beep($args->{'beepbefore'}); # my $command = $self->_mk_cmnd(" --gauge",@_); # $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'}))||' ') . '"'; # $command .= ' "' . ($args->{'height'}||'20') . '"'; # $command .= ' "' . ($args->{'width'}||'65') . '"'; # $command .= ' "' . ($args->{'percentage'}||'0') . '"'; # $self->{'_GAUGE'} = new FileHandle; # $self->{'_GAUGE'}->open("| $command"); # my $rv = $? >> 8; # $self->{'_GAUGE'}->autoflush(1); # $self->ra('null'); # $self->rs('null'); # if ($rv && $rv >= 1) { # return(0); # } else { # return(1); # } # } # sub gauge_inc { # my $self = $_[0]; # my $incr = $_[1] || 1; # return(0) unless defined $self->{'_GAUGE'}; # my $fh = $self->{'_GAUGE'}; # $self->{'_GAUGE_PERCENT'} += $incr; # $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; # unless ($self->{'_GAUGE_PERCENT'} < 100) { # $self->gauge_end(); # return(1); # } # print $fh $self->{'_GAUGE_PERCENT'}."\n"; # return(((defined $self->{'_GAUGE'}) ? 1 : 0)); # } # sub gauge_dec { # my $self = $_[0]; # my $decr = $_[1] || 1; # return(0) unless defined $self->{'_GAUGE'}; # my $fh = $self->{'_GAUGE'}; # $self->{'_GAUGE_PERCENT'} -= $decr; # $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; # unless ($self->{'_GAUGE_PERCENT'} < 100) { # $self->gauge_end(); # return(1); # } # print $fh $self->{'_GAUGE_PERCENT'}."\n"; # return(((defined $self->{'_GAUGE'}) ? 1 : 0)); # } # sub gauge_set { # my $self = $_[0]; # my $perc = $_[1] || $self->{'_GAUGE_PERCENT'} || 1; # my $fh = $self->{'_GAUGE'}; # return(0) unless $self->{'_GAUGE'}; # $self->{'_GAUGE_PERCENT'} = $perc; # unless ($self->{'_GAUGE_PERCENT'} < 100) { # $self->gauge_end(); # return(1); # } # $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; # print $fh $self->{'_GAUGE_PERCENT'}."\n"; # return(((defined $self->{'_GAUGE'}) ? 1 : 0)); # } # 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_end { # my $self = $_[0]; # my $fh = $self->{'_GAUGE'}; # return(0) unless $self->{'_GAUGE'}; # $SIG_CODE->{$$} = $self; local $SIG{'PIPE'} = \&_del_gauge; # $self->{'_GAUGE'}->close(); # delete($self->{'_GAUGE'}); # delete($self->{'_GAUGE_PERCENT'}); # $self->_beep(); # $self->ra('null'); # $self->rs('null'); # return(1); # } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/GDialog.pod����������������������������������������������������000644 �000765 �000024 �00000023025 12202472000 021352� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::GDialog =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) 2013 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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/KDialog.pm�����������������������������������������������������000644 �000765 �000024 �00000040552 12202472000 021214� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::KDialog; ############################################################################### # Copyright (C) 2013 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 Carp; use Cwd qw( abs_path ); use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}); } return($self); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Override Inherited Methods #: #: execute a simple command (return the exit code only); sub command_state { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("command: ".$cmnd,1); system($cmnd . "> /dev/null 2> /dev/null"); my $rv = $? >> 8; $self->_debug("command rv: ".$rv,2); return($rv); } #: execute a command and return the exit code and one-line SCALAR sub command_string { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("command: ".$cmnd,1); chomp(my $text = `$cmnd 2> /dev/null`); my $rv = $? >> 8; $self->_debug("command rs: ".$rv." '".$text."'",2); 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]; $self->_debug("command: ".$cmnd,1); chomp(my $text = `$cmnd 2> /dev/null`); my $rv = $? >> 8; $self->_debug("command ra: ".$rv." '".$text."'",2); return([split(/\n/,$text)]) unless defined wantarray; return (wantarray) ? ($rv,[split(/\n/,$text)]) : [split(/\n/,$text)]; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Private Methods #: sub _mk_cmnd { my $self = shift(); my $final = shift(); my $cmnd; my $args = $self->_merge_attrs(@_); $cmnd = $self->{'_opts'}->{'bin'}; $cmnd .= ' --title "' . ($args->{'title'} || $self->{'_opts'}->{'title'}) . '"' unless not $args->{'title'} and not $self->{'_opts'}->{'title'}; $cmnd .= ' --caption "' . ($args->{'caption'} || $self->{'_opts'}->{'caption'}) . '"' unless not $args->{'caption'} and not $self->{'_opts'}->{'caption'}; $cmnd .= ' --icon "' . ($args->{'icon'} || $self->{'_opts'}->{'icon'}) . '"' unless not $args->{'icon'} and not $self->{'_opts'}->{'icon'}; $cmnd .= ' --miniicon "' . ($args->{'miniicon'} || $self->{'_opts'}->{'miniicon'}) . '"' unless not $args->{'miniicon'} and not $self->{'_opts'}->{'miniicon'}; $cmnd .= ' --separate-output' unless not $args->{'separate-output'} and not $self->{'_opts'}->{'separate-output'}; $cmnd .= " " . $final; return($cmnd); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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 $command = $self->_mk_cmnd(' --'.$args->{'yesno'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; my $rv = $self->command_state($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $this_rv = 0; } else { $self->ra("YES"); $self->rs("YES"); $this_rv = 1; } $self->_post($args); return($this_rv); } 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 $command = $self->_mk_cmnd(' --'.$args->{'inputbox'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'init'}||$args->{'entry'}||'') . '"' unless (not $args->{'init'} and not $args->{'entry'}) or $args->{'inputbox'} ne 'inputbox'; my ($rv,$text) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($text); $self->rs($text); $this_rv = $text; } $self->_post($args); return($this_rv); } 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 $command = $self->_mk_cmnd(' --'.$args->{'msgbox'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; my $rv = $self->command_state($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } $self->_post($args); return($this_rv); } 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')); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --textbox",@_); $command .= ' "' . $args->{'filename'} . '"' unless not $args->{'filename'}; $command .= ' "' . $args->{'width'} . '"' unless not $args->{'width'}; $command .= ' "' . $args->{'height'} . '"' unless not $args->{'height'}; my ($rv,$text) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } $self->_post($args); return($this_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,@_); my $command = $self->_mk_cmnd(" --menu",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', ' ' ] unless ref($args->{'list'}) eq "ARRAY"; foreach my $item (@{$args->{'list'}}) { $command .= ' "' . $item . '"'; } } else { $args->{'items'} = [ ' ', ' ' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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,@_); $self->{'checklist'} ||= 'checklist'; my $command = $self->_mk_cmnd(" --".$self->{'checklist'},@_,'separate-output',1); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: a radio list 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 $command = $self->_mk_cmnd(" --".$self->{'radiolist'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --".$args->{'fselect'},@_); $command .= ' "' . ($args->{'path'}||abs_path()) . '"'; $command .= ' "' . ($args->{'filter'}||'*') . '"' unless $args->{'getexistingdirectory'}; my ($rv,$file) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($file); $self->rs($file); $this_rv = $file; } $self->_post($args); return($this_rv); } 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; ������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/KDialog.pod����������������������������������������������������000644 �000765 �000024 �00000017657 12202472000 021374� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::KDialog =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) 2013 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 ���������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/Nautilus.pm����������������������������������������������������000644 �000765 �000024 �00000013007 12202472000 021501� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::Nautilus; ############################################################################### # Copyright (C) 2013 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 Carp; # # Please read the POD for copyright and licensing issues. # BEGIN { use vars qw($VERSION); $VERSION = '1.09'; } sub new { my $proto = shift(); my $class = ref($proto) || $proto; my $self = {}; bless($self, $class); 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(); my $desktop_dir = $ENV{'HOME'} . "/Desktop"; if ( eval { require Gnome2::GConf; 1; } ) { use Gnome2::GConf; my $gconf = Gnome2::GConf::Client->get_default(); $desktop_dir = $ENV{'HOME'} if $gconf->get_bool( '/apps/nautilus/preferences/desktop_is_home_dir' ); } else { my $gconf_xml = $ENV{'HOME'} . '/.gconf/apps/nautilus/preferences/%gconf.xml'; if ( -r $gconf_xml ) { if ( open( GCONF, "<" . $gconf_xml ) ) { my $RAW = undef; { local $/; $RAW = <GCONF>; } close( GCONF ); # <entry name="desktop_is_home_dir" mtime="1090894369" type="bool" value="true"> if ( $RAW =~ m!\s+[^"]+\"desktop_is_home_dir\"[^"]+\"\d*\"[^"]+\"bool\"\svalue=\"false\"\>! ) { $desktop_dir = $ENV{'HOME'}; } } } } return( $desktop_dir ); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/Nautilus.pod���������������������������������������������������000644 �000765 �000024 �00000011625 12202472000 021653� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::Nautilus =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 usefull 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) 2013 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 �����������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/Whiptail.pm����������������������������������������������������000644 �000765 �000024 �00000046555 12202472000 021474� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::Whiptail; ############################################################################### # Copyright (C) 2013 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 FileHandle; use Carp; use Time::HiRes qw( sleep ); use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}); } 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 _mk_cmnd { my $self = shift(); my $final = shift(); my $cmnd = $self->{'_opts'}->{'bin'}; my $args = $self->_merge_attrs(@_); $cmnd .= ' --title "' . ($args->{'title'} || ' ') . '"' unless not $args->{'title'}; $cmnd .= ' --backtitle "' . ($args->{'backtitle'} || ' ') . '"' unless not $args->{'backtitle'}; $cmnd .= ' --separate-output' unless not $args->{'separate-output'}; $cmnd .= " " . $final; return($cmnd); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: Override Inherited Methods #: sub command_state { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("".$cmnd); system($cmnd . " 2> /dev/null"); return($? >> 8); } sub command_string { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug($cmnd); $self->gen_tempfile_name(); # don't accept the first result my $tmpfile = $self->gen_tempfile_name(); my $text; system($cmnd." 2> ".$tmpfile); my $rv = $? >> 8; if (-f $tmpfile # don't assume the file exists && open(WHIPF,"<".$tmpfile)) { local $/; $text = <WHIPF>; close(WHIPF); unlink($tmpfile); } else { $text = ""; } return($text) unless defined wantarray; return (wantarray) ? ($rv,$text) : $text; } sub command_array { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug($cmnd); $self->gen_tempfile_name(); # don't accept the first result my $tmpfile = $self->gen_tempfile_name(); my $text; system($cmnd." 2> ".$tmpfile); my $rv = $? >> 8; if (-f $tmpfile # don't assume the file exists && open(WHIPF,"<".$tmpfile)) { local $/; $text = <WHIPF>; close(WHIPF); unlink($tmpfile); } else { $text = ""; } return([split("\n",$text)]) unless defined wantarray; return (wantarray) ? ($rv,[split("\n",$text)]) : [split("\n",$text)]; } #: indent and organize the text argument sub _organize_text { my $self = $_[0]; my $text = $_[1] || return(); my $width = $_[2] || 65; $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); my $max = @array; for (my $i = 0; $i < $max; $i++) { $array[$i] = $self->_esc_text($array[$i]); } if ($self->{'scale'}) { foreach my $line (@array) { my $s_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; 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); return($text); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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 $command = $self->_mk_cmnd(' --yesno',@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my $rv = $self->command_state($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $self->rv($rv); $this_rv = 0; } else { $self->ra("YES"); $self->rs("YES"); $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $cmnd_prefix = ' --inputbox'; if ($args->{'password'}) { $cmnd_prefix = ' --passwordbox'; } my $command = $self->_mk_cmnd($cmnd_prefix,@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'init'}||$args->{'entry'}||'') . '"' unless not $args->{'init'} and not $args->{'entry'}; my ($rv,$text) = $self->command_string($command); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $this_rv = 0; } else { $self->rv('null'); $self->rs($text); $self->ra($text); $this_rv = $text; } $self->_post($args); return($this_rv); } #: 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 $command = $self->_mk_cmnd(' --scrolltext --'.$args->{'msgbox'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my $rv = $self->command_state($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $this_rv = 0; } else { if (($args->{'msgbox'} eq "infobox") && ($args->{'timeout'} || $args->{'wait'})) { my $s = int(($args->{'wait'}) ? $args->{'wait'} : ($args->{'timeout'}) ? ($args->{'timeout'} / 1000.0) : 1.0); sleep($s); } $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_rv); } sub infobox { my $self = shift(); return($self->msgbox('caller',((caller(1))[3]||'main'),@_,'msgbox','infobox')); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --scrolltext --textbox",@_); $command .= ' "' . ($args->{'path'}||'.') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$text) = $self->command_string($command); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $this_rv = 0; } else { $self->rv('null'); $this_rv = 1; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --menu",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', ' ' ] unless ref($args->{'list'}) eq "ARRAY"; foreach my $item (@{$args->{'list'}}) { $command .= ' "' . $item . '"'; } } else { $args->{'items'} = [ ' ', ' ' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $self->ra('null'); $this_rv = 0; } else { $self->rv('null'); $self->rs($selected); $self->ra($selected); $this_rv = $selected; } } 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 $command = $self->_mk_cmnd(" --".$self->{'checklist'},@_,'separate-output',1); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_array($command); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->ra('null'); $self->rs('null'); $this_rv = 0; } else { $self->rv('null'); $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } 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 $command = $self->_mk_cmnd(" --".$self->{'radiolist'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); my $this_rv; if ($rv && $rv >= 1) { $self->rv($rv); $self->rs('null'); $self->ra('null'); $this_rv = 0; } else { $self->rv('null'); $self->rs($selected); $self->ra($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --gauge",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($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; ���������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/Whiptail.pod���������������������������������������������������000644 �000765 �000024 �00000022474 12202472000 021634� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::Whiptail =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) 2013 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/XDialog.pm�����������������������������������������������������000644 �000765 �000024 �00000151412 12202472000 021227� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::XDialog; ############################################################################### # Copyright (C) 2013 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 FileHandle; use File::Basename; use Carp; use Cwd qw( abs_path ); use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}->{'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) $self->{'_opts'}->{'width'} = $cfg->{'width'} || 0; $self->{'_opts'}->{'height'} = $cfg->{'height'} || 0; $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; 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 _mk_cmnd { my $self = shift(); my $final = shift(); my $cmnd = $self->{'_opts'}->{'bin'}; my $args = $self->_merge_attrs(@_); $cmnd = 'XDIALOG_HIGH_DIALOG_COMPAT="1" ' . $cmnd unless not $args->{'XDIALOG_HIGH_DIALOG_COMPAT'}; # --wmclass <name> $cmnd .= ' --wmclass "' . $args->{'wmclass'} . '"' unless not $args->{'wmclass'}; # --rc-file <gtkrc filename> $cmnd .= ' --rc-file "' . $args->{'rcfile'} . '"' unless not $args->{'rcfile'} or not -r $args->{'rcfile'}; # --begin <Yorg> <Xorg> (all) $cmnd .= ' --begin "' . $args->{'begin'}->[0] . '" "' . $args->{'begin'}->[1] . '"' unless not $args->{'begin'} or not ref($args->{'begin'}) or ref($args->{'begin'}) ne "ARRAY"; # --editable (combobox) $cmnd .= ' --editable' unless not $args->{'editable'}; # --title <title> $cmnd .= ' --title "' . $args->{'title'} . '"' unless not $args->{'title'}; # --backtitle <backtitle> $cmnd .= ' --backtitle "' . $args->{'backtitle'} . '"' unless not $args->{'backtitle'}; # --allow-close | --no-close $cmnd .= ' --allow-close' unless not $args->{'allow-close'} and not $args->{'allowclose'}; $cmnd .= ' --no-close' unless not $args->{'no-close'} and not $args->{'noclose'}; # --screen-center | --under-mouse | --auto-placement $cmnd .= ' --screen-center' unless not $args->{'screen-center'} and not $args->{'screencenter'}; $cmnd .= ' --under-mouse' unless not $args->{'under-mouse'} and not $args->{'undermouse'}; $cmnd .= ' --auto-placement' unless not $args->{'auto-placement'} and not $args->{'autoplacement'}; # --center | --right | --left | --fill $cmnd .= ' --center' unless not $args->{'center'}; $cmnd .= ' --right' unless not $args->{'right'}; $cmnd .= ' --left' unless not $args->{'left'}; $cmnd .= ' --fill' unless not $args->{'fill'}; # --no-wrap | --wrap $cmnd .= ' --no-wrap' unless not $args->{'no-wrap'} and not $args->{'nowrap'}; $cmnd .= ' --wrap' unless not $args->{'wrap'}; # --cr-wrap | --no-cr-wrap $cmnd .= ' --crwrap' unless not $args->{'crwrap'}; $cmnd .= ' --nocrwrap' unless not $args->{'nocrwrap'}; # --buttons-style default|icon|text $cmnd .= ' --buttons-style "' . ($args->{'buttonsstyle'}||$args->{'buttons-style'}) . '"' unless not $args->{'buttons-style'} and not $args->{'buttonsstyle'}; # --fixed-font (tailbox, textbox, and editbox) $cmnd .= ' --fixed-font' unless not $args->{'fixed-font'} and not $args->{'fixedfont'}; # --time-stamp | --date-stamp (logbox) $cmnd .= ' --time-stamp' unless not $args->{'time-stamp'} and not $args->{'timestamp'}; $cmnd .= ' --date-stamp' unless not $args->{'date-stamp'} and not $args->{'datestamp'}; # --reverse (logbox) $cmnd .= ' --reverse' unless not $args->{'reverse'}; # --keep-colors (logbox) $cmnd .= ' --keep-colors' unless not $args->{'keep-colors'} and not $args->{'keep-colours'} and not $args->{'keepcolors'} and not $args->{'keepcolours'}; # --interval <timeout> (input(s) boxes, combo box, range(s) boxes, spin(s) boxes, list boxes, menu box, treeview, calendar, timebox) $cmnd .= ' --interval "' . $args->{'interval'} . '"' unless not $args->{'interval'}; # --no-tags (menubox, checklist and radiolist) $cmnd .= ' --no-tags' unless not $args->{'no-tags'} and not $args->{'notags'}; # --item-help (menubox, checklist, radiolist, buildlist and treeview) $cmnd .= ' --item-help' unless not $args->{'item-help'} and not $args->{'itemhelp'}; # --default-item <tag> (menubox) $cmnd .= ' --default-item "' . ($args->{'defaultitem'}||$args->{'default-item'}) . '"' unless not $args->{'default-item'} and not $args->{'defaultitem'}; # --icon <xpm filename> (textbox, editbox, tailbox, logbox, fselect and dselect) $cmnd .= ' --icon "' . $args->{'icon'} . '"' unless not $args->{'icon'}; # --no-ok (tailbox and logbox) $cmnd .= ' --no-ok' unless not $args->{'no-ok'} and not $args->{'nook'}; # --no-cancel (infobox, gauge and progress) $cmnd .= ' --no-cancel' unless not $args->{'no-cancel'} and not $args->{'nocancel'}; # --no-buttons (textbox, tailbox, logbox, infobox fselect and dselect) $cmnd .= ' --no-buttons' unless not $args->{'no-buttons'} and not $args->{'nobuttons'}; # --default-no !(wizard) $cmnd .= ' --default-no' unless not $args->{'default-no'} and not $args->{'defaultno'}; # --wizard !(msgbox, infobox, gauge and progress) $cmnd .= ' --wizard' unless not $args->{'wizard'}; # --help <help> (infobox, gauge and progress) $cmnd .= ' --help "' . $args->{'help'} . '"' unless not $args->{'help'}; # --print <printer> (textbox, editbox and tailbox) $cmnd .= ' --print "' . $args->{'print'} . '"' unless not $args->{'print'}; # --check <label> !(infobox, gauge and progress) $cmnd .= ' --check "' . $args->{'check'}||$self->{'_opts'}->{'check'} . '"' unless not $args->{'check'}; # --ok-label <label> !(wizard) $cmnd .= ' --ok-label "' . ($args->{'oklabel'}||$args->{'ok-label'}) . '"' unless not $args->{'ok-label'} and not $args->{'oklabel'}; # --cancel-label <label> !(wizard) $cmnd .= ' --cancel-label "' . ($args->{'cancellabel'}||$args->{'cancel-label'}) . '"' unless not $args->{'cancel-label'} and not $args->{'cancellabel'}; # --beep | --beep-after (all) # $cmnd .= ' --beep' unless not $args->{'beep'}; # --ignore-eof (infobox and gauge) $cmnd .= ' --ignore-eof' unless not $args->{'ignore-eof'} and not $args->{'ignoreeof'}; # --smooth (tailbox and logbox) $cmnd .= ' --smooth' unless not $args->{'smooth'}; $cmnd .= " " . $final; return($cmnd); } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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 $command = $self->_mk_cmnd(" --separate-output --combobox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; if ($args->{'list'}) { $args->{'list'} = [ $args->{'list'} ] unless ref($args->{'list'}) eq "ARRAY"; foreach my $item (@{$args->{'list'}}) { $command .= ' "' . $item . '"'; } } else { $args->{'items'} = [ $args->{'items'} ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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 $command = $self->_mk_cmnd(" --rangebox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'min'}||'0') . '"'; $command .= ' "' . ($args->{'max'}||'100') . '"'; $command .= ' "' . ($args->{'def'}||'0') . '"'; my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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 $command = $self->_mk_cmnd(" --separate-output --2rangesbox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'label1'}||' ') . '"'; $command .= ' "' . ($args->{'min1'}||'0') . '"'; $command .= ' "' . ($args->{'max1'}||'100') . '"'; $command .= ' "' . ($args->{'def1'}||'0') . '"'; $command .= ' "' . ($args->{'label2'}||' ') . '"'; $command .= ' "' . ($args->{'min2'}||'0') . '"'; $command .= ' "' . ($args->{'max2'}||'100') . '"'; $command .= ' "' . ($args->{'def2'}||'0') . '"'; my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->rs('null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } # --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 $command = $self->_mk_cmnd(" --separate-output --3rangesbox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'label1'}||' ') . '"'; $command .= ' "' . ($args->{'min1'}||'0') . '"'; $command .= ' "' . ($args->{'max1'}||'100') . '"'; $command .= ' "' . ($args->{'def1'}||'0') . '"'; $command .= ' "' . ($args->{'label2'}||' ') . '"'; $command .= ' "' . ($args->{'min2'}||'0') . '"'; $command .= ' "' . ($args->{'max2'}||'100') . '"'; $command .= ' "' . ($args->{'def2'}||'0') . '"'; $command .= ' "' . ($args->{'label3'}||' ') . '"'; $command .= ' "' . ($args->{'min3'}||'0') . '"'; $command .= ' "' . ($args->{'max3'}||'100') . '"'; $command .= ' "' . ($args->{'def3'}||'0') . '"'; my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } # --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,@_); my $command = $self->_mk_cmnd(" --separate-output --spinbox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'min1'}||'0') . '"'; $command .= ' "' . ($args->{'max1'}||'100') . '"'; $command .= ' "' . ($args->{'def1'}||'') . '"'; $command .= ' "' . ($args->{'label1'}||'') . '"'; my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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 $command = $self->_mk_cmnd(" --separate-output --2spinsbox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'min1'}||'0') . '"'; $command .= ' "' . ($args->{'max1'}||'100') . '"'; $command .= ' "' . ($args->{'def1'}||'') . '"'; $command .= ' "' . ($args->{'label1'}||' ') . '"'; $command .= ' "' . ($args->{'min2'}||'0') . '"'; $command .= ' "' . ($args->{'max2'}||'100') . '"'; $command .= ' "' . ($args->{'def2'}||' ') . '"'; $command .= ' "' . ($args->{'label2'}||' ') . '"'; my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } # --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 $command = $self->_mk_cmnd(" --separate-output --3spinsbox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'min1'}||'0') . '"'; $command .= ' "' . ($args->{'max1'}||'100') . '"'; $command .= ' "' . ($args->{'def1'}||'') . '"'; $command .= ' "' . ($args->{'label1'}||' ') . '"'; $command .= ' "' . ($args->{'min2'}||'0') . '"'; $command .= ' "' . ($args->{'max2'}||'100') . '"'; $command .= ' "' . ($args->{'def2'}||' ') . '"'; $command .= ' "' . ($args->{'label2'}||' ') . '"'; $command .= ' "' . ($args->{'min3'}||'0') . '"'; $command .= ' "' . ($args->{'max3'}||'100') . '"'; $command .= ' "' . ($args->{'def3'}||' ') . '"'; $command .= ' "' . ($args->{'label3'}||' ') . '"'; my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->rs('null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } # --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'; my $command = $self->_mk_cmnd(" --separate-output --".$self->{'buildlist'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; $command .= ' "'.($info->[2]||' ').'"' unless not $args->{'itemhelp'}; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->rs('null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } # --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'; my $command = $self->_mk_cmnd(" --separate-output --".$self->{'treeview'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1, 1 ] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'" "'.($info->[2]||1).'"'; $command .= ' "'.($info->[3]||' ').'"' unless not $args->{'itemhelp'}; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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,@_); my $command = $self->_mk_cmnd(" --separate-output --calendar",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'14') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'day'}||'1') . '"'; $command .= ' "' . ($args->{'month'}||'1') . '"'; $command .= ' "' . ($args->{'year'}||'1970') . '"'; my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { chomp($selected); $self->ra(split(/\//,$selected)); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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 $command = $self->_mk_cmnd(" --separate-output --timebox",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'14') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(split(/\:/,$selected)); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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 $command = $self->_mk_cmnd(' --yesno',@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my $rv = $self->command_state($command); $self->rv($rv||'null'); my $this_rv; if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $this_rv = 0; } else { $self->ra("YES"); $self->rs("YES"); $this_rv = 1; } $self->_post($args); return($this_rv); } # --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 $val = $args->{'inputs'} || $args->{'password'} || 1; my $cmnd_prefix; if ($args->{'password'}) { if ($val == 3) { $cmnd_prefix = ' --separate-output --password --password --password --3inputsbox'; } elsif ($val == 2) { $cmnd_prefix = ' --separate-output --password --password --2inputsbox'; } else { $cmnd_prefix = ' --password --inputbox'; } } else { if ($val == 3) { $cmnd_prefix = ' --separate-output --3inputsbox'; } elsif ($val == 2) { $cmnd_prefix = ' --separate-output --2inputsbox'; } else { $cmnd_prefix = ' --inputbox'; } } my $command = $self->_mk_cmnd($cmnd_prefix,@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'entry'}||$args->{'init'}||'') . '"' if $val == 1; $command .= ' "' . ($args->{'label1'}||' ') . '"' if $val > 1; $command .= ' "' . ($args->{'input1'}||'') . '"' if $val > 1; $command .= ' "' . ($args->{'label2'}||' ') . '"' if $val >= 2; $command .= ' "' . ($args->{'input2'}||'') . '"' if $val >= 2; $command .= ' "' . ($args->{'label3'}||' ') . '"' if $val >= 3; $command .= ' "' . ($args->{'input3'}||'') . '"' if $val >= 3; my ($rv,$text); if ($val == 1) { ($rv,$text) = $self->command_string($command); } else { ($rv,$text) = $self->command_array($command); } $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { if ($val == 1) { $self->ra($text); $self->rs($text); } else { $self->ra(@$text); $self->rs(join("\n",@$text)); } $this_rv = $text; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } 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 $command = $self->_mk_cmnd(' --'.$args->{'msgbox'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . (($args->{'wait'}) ? $args->{'wait'} * 1000 : ($args->{'timeout'}||'5000')) . '"' unless $args->{'msgbox'} ne 'infobox'; my $rv = $self->command_state($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } $self->_post($args); return($this_rv); } # --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'; my $command = $self->_mk_cmnd(" --".$args->{'textbox'},@_); $command .= ' "' . ($args->{'filename'}||$args->{'path'}||'.') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$text) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(($text) ? [ $text ] : 'null'); $self->rs($text||'null'); $this_rv = $text || 1; } $self->_post($args); return($this_rv); } 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 $command = $self->_mk_cmnd(" --separate-output --menu",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', ' ' ] unless ref($args->{'list'}) eq "ARRAY"; foreach my $item (@{$args->{'list'}}) { $command .= ' "' . $item . '"'; } } else { $args->{'items'} = [ ' ', ' ' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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 $command = $self->_mk_cmnd(" --separate-output --".$self->{'checklist'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; $command .= ' "'.($info->[2]||' ').'"' unless not $args->{'itemhelp'}; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->rs('null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $this_rv = $selected; } $self->_post($args); return($this_rv) unless ref($this_rv) eq "ARRAY"; return(@{$this_rv}); } # --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 $command = $self->_mk_cmnd(" --separate-output --".$self->{'radiolist'},@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'menuheight'}||$args->{'listheight'}||'5') . '"'; if ($args->{'list'}) { $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); $command .= ' "'.$item.'" "'.$info->[0].'" "'.(($info->[1]) ? 'on' : 'off').'"'; $command .= ' "'.($info->[2]||' ').'"' unless not $args->{'itemhelp'}; } } else { $args->{'items'} = [ ' ', ' ', 'off' ] unless ref($args->{'items'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($selected); $self->rs($selected); $this_rv = $selected; } $self->_post($args); return($this_rv); } # --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,@_); my $command = $self->_mk_cmnd(" --fselect",@_); my $path = $args->{'path'} || abs_path(); $command .= ' "' . ((-d $path) ? $path . '/' : $path) . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$file) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($file); $self->rs($file); $this_rv = $file; } $self->_post($args); return($this_rv); } # --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,@_); my $command = $self->_mk_cmnd(" --dselect",@_); my $path = $args->{'path'} || abs_path(); $command .= ' "' . ((-d $path) ? $path . '/' : $path) . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; my ($rv,$file) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($file); $self->rs($file); $this_rv = $file; } $self->_post($args); return($this_rv); } # --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 $command = $self->_mk_cmnd(" --progress",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($args->{'maxdots'}||'') . '"' unless not $args->{'maxdots'} and not $args->{'msglen'}; $command .= ' "' . ($args->{'msglen'}||'') . '"' unless not $args->{'msglen'}; $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'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } return($this_rv); } 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 $command = $self->_mk_cmnd(" --gauge",@_); $command .= ' "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"'; $command .= ' "' . ($args->{'height'}||'20') . '"'; $command .= ' "' . ($args->{'width'}||'65') . '"'; $command .= ' "' . ($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'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } return($this_rv); } 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; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/XDialog.pod����������������������������������������������������000644 �000765 �000024 �00000061227 12202472000 021401� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::XDialog =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) 2013 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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/XOSD.pm��������������������������������������������������������000644 �000765 �000024 �00000026176 12202472000 020465� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::XOSD; ############################################################################### # Copyright (C) 2013 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 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.09'; } 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'}); } 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'}||'')."\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]||'')."\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; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/XOSD.pod�������������������������������������������������������000644 �000765 �000024 �00000013524 12202472000 020624� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::XOSD =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 1=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) 2013 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/Zenity.pm������������������������������������������������������000644 �000765 �000024 �00000052430 12202472000 021162� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������package UI::Dialog::Backend::Zenity; ############################################################################### # Copyright (C) 2013 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 FileHandle; use Cwd qw( abs_path ); use Carp; use UI::Dialog::Backend; BEGIN { use vars qw( $VERSION @ISA ); @ISA = qw( UI::Dialog::Backend ); $VERSION = '1.09'; } #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: #: 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'}); } my $command = $self->{'_opts'}->{'bin'}." --version"; my $version = `$command 2>&1`; chomp( $version ); $self->{'ZENITY_VERSION'} = $version || '1'; 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 _mk_cmnd { my $self = shift(); my $cmnd = shift(); my $args = shift(); $ENV{'ZENITY_CANCEL'} = '1'; $ENV{'ZENITY_ERROR'} = '254'; $ENV{'ZENITY_ESC'} = '255'; $ENV{'ZENITY_EXTRA'} = '3'; $ENV{'ZENITY_HELP'} = '2'; $ENV{'ZENITY_OK'} = '0'; $cmnd = $self->{'_opts'}->{'bin'} . " " . $cmnd; $cmnd .= ' --title "' . $args->{'title'} . '"' unless not $args->{'title'}; $cmnd .= ' --window-icon "' . $args->{'window-icon'} . '"' unless not $args->{'window-icon'}; $cmnd .= ' --width "' . $args->{'width'} . '"' unless not $args->{'width'}; $cmnd .= ' --height "' . $args->{'height'} . '"' unless not $args->{'height'}; $cmnd .= ' --display "'.$args->{'display'} . '"' unless not $args->{'display'}; $cmnd .= ' --name "'.$args->{'name'} . '"' unless not $args->{'name'}; $cmnd .= ' --class "'.$args->{'class'} . '"' unless not $args->{'class'}; return($cmnd); } 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 #: #: execute a simple command (return the exit code only); sub command_state { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("command: ".$cmnd,1); system($cmnd . "> /dev/null 2> /dev/null"); my $rv = $? >> 8; $self->_debug("command rv: ".$rv,2); return($rv); } #: execute a command and return the exit code and one-line SCALAR sub command_string { my $self = $_[0]; my $cmnd = $_[1]; $self->_debug("command: ".$cmnd,1); my $text; if ($self->_is_bad_version()) { #we should ignore STDERR... chomp($text = `$cmnd`); } else { chomp($text = `$cmnd 2>&1`); } my $rv = $? >> 8; $self->_debug("command rs: ".$rv." '".$text."'",2); 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]; $self->_debug("command: ".$cmnd,1); my $text; if ($self->_is_bad_version()) { #we should ignore STDERR... chomp($text = `$cmnd`); } else { chomp($text = `$cmnd 2>&1`); } my $rv = $? >> 8; $self->_debug("command ra: ".$rv." '".$text."'",2); return([split(/\n/,$text)]) unless defined wantarray; return (wantarray) ? ($rv,[split(/\n/,$text)]) : [split(/\n/,$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 $command = $self->_mk_cmnd(" --question",$args); $command .= ' --text "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"' unless not $args->{'text'}; my $rv = $self->command_state($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $self->ra("NO"); $self->rs("NO"); $this_rv = 0; } else { $self->ra("YES"); $self->rs("YES"); $this_rv = 1; } $self->_post($args); return($this_rv); } #: 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,@_); my $command = $self->_mk_cmnd(" --entry",$args); $command .= ' --text "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"' unless not $args->{'text'}; $command .= ' --hide-text' unless not $args->{'hide-text'}; $command .= ' --entry-text "' . ($args->{'entry'}||$args->{'init'}) . '"' unless not $args->{'entry'} and not $args->{'init'}; my ($rv,$text) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); my $this_rv; if ($rv && $rv >= 1) { $self->rs('null'); $this_rv = 0; } else { $self->ra($text); $self->rs($text); $this_rv = $text; } $self->_post($args); return($this_rv); } 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 $command = $self->_mk_cmnd((($args->{'error'}) ? " --error" : ($args->{'warning'}) ? " --warning" : " --info"),$args); $command .= ' --text "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"' unless not $args->{'text'}; my $rv = $self->command_state($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $this_rv = 1; } $self->_post($args); return($this_rv); } 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 $command = $self->_mk_cmnd(" --text-info",$args); $command .= ' --editable' unless not $args->{'editable'}; $command .= ' --filename "' . ($args->{'path'}||$args->{'filename'}) . '"' unless not $args->{'filename'} and not $args->{'path'}; my ($rv,$text) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv = 0; if ($rv && $rv >= 1) { $self->rs('null'); } elsif ($args->{'editable'}) { $self->ra($text); $self->rs($text); $this_rv = $text; } else { $this_rv = 1; } $self->_post($args); return($this_rv); } 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 $command = $self->_mk_cmnd(" --list",$args); $command .= ($args->{'checklist'}) ? ' --checklist' : ($args->{'radiolist'}) ? ' --radiolist' : ""; $command .= ' --separator $\'\n\''; #: not quite sure how to implement the editability... # $command .= ' --editable' unless not $args->{'editable'}; #: --text is not implemented for list widgets, yet... # $command .= ' --text "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"' unless not $args->{'text'}; if ($args->{'list'} && ($args->{'checklist'} || $args->{'radiolist'})) { if ($args->{'checklist'} || $args->{'radiolist'}) { $command .= " --column ' ' --column ' ' --column ' '"; } else { $command .= " --column ' ' --column ' '"; } $args->{'list'} = [ ' ', [' ', 1] ] unless ref($args->{'list'}) eq "ARRAY"; my ($item,$info); while (@{$args->{'list'}}) { $item = shift(@{$args->{'list'}}); $info = shift(@{$args->{'list'}}); if (ref($info) eq "ARRAY") { $command .= ' "'.(($info->[1]) ? 'TRUE' : 'FALSE').'" "'.$item.'" "'.$info->[0].'"'; } else { $command .= ' "'.$item.'" "'.$info.'"'; } } } else { $args->{'columns'} = [ ' ', ' ' ] unless ref($args->{'columns'}) eq "ARRAY"; foreach my $column (@{$args->{'columns'}}) { $command .= ' --column "' . $column . '"'; } $args->{'items'} = $args->{'list'} unless not $args->{'list'}; $args->{'items'} = [ ' ',' ' ] unless ref($args->{'columns'}) eq "ARRAY"; foreach my $item (@{$args->{'items'}}) { $command .= ' "' . $item . '"'; } } my ($rv,$selected) = $self->command_array($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); if ($rv && $rv >= 1) { $self->_post($args); return(0); } else { if ($args->{'checklist'}) { $self->ra(@$selected); $self->rs(join("\n",@$selected)); $self->_post($args); return(@{$selected}); } else { $self->ra($selected->[0]); $self->rs($selected->[0]); $self->_post($args); return($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,@_); $args->{'path'} = (-d $args->{'path'}) ? $args->{'path'}."/" : $args->{'path'}; $args->{'path'} =~ s!/+!/!g; my $command = $self->_mk_cmnd(" --file-selection",$args); $command .= ' --filename "' . ($args->{'path'}||abs_path()) . '"'; $self->_debug("fselect: ".$args->{'path'}); my ($rv,$file) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($file); $self->rs($file); $this_rv = $file; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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,@_); $args->{'path'} = (-d $args->{'path'}) ? $args->{'path'}."/" : $args->{'path'}; $args->{'path'} =~ s!/+!/!g; my $command = $self->_mk_cmnd(" --file-selection --directory",$args); $command .= ' --filename "' . ($args->{'path'}||abs_path()) . '"'; $self->_debug("fselect: ".$args->{'path'}); my ($rv,$file) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { $self->ra($file); $self->rs($file); $this_rv = $file; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --calendar",$args); $command .= ' --text "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"' unless not $args->{'text'}; $command .= ' --date-format "' . ($args->{'date-format'}||'%d/%m/%y') . '"'; $command .= ' --day "' . $args->{'day'} . '"' unless not $args->{'day'}; $command .= ' --month "' . $args->{'month'} . '"' unless not $args->{'month'}; $command .= ' --year "' . $args->{'year'} . '"' unless not $args->{'year'}; my ($rv,$date) = $self->command_string($command); $self->rv($rv||'null'); $self->ra('null'); $self->rs('null'); my $this_rv; if ($rv && $rv >= 1) { $this_rv = 0; } else { chomp($date); # the end programmer can alter the date format $self->ra(split(/\//,$date)) if $date =~ /^\d+\/\d+\/\d+$/; $self->rs($date); $this_rv = $date; } $self->_post($args); return($this_rv); } #:+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #: 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 $command = $self->_mk_cmnd(" --progress",$args); $command .= ' --text "' . (($args->{'literal'} ? $args->{'text'} : $self->_organize_text($args->{'text'},$args->{'width'}))||' ') . '"' unless not $args->{'text'}; $command .= ' --percentage "' . ($args->{'percentage'}||'0') . '"'; $command .= ' --pulsate' unless not $args->{'pulsate'}; $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; 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; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/lib/UI/Dialog/Backend/Zenity.pod�����������������������������������������������������000644 �000765 �000024 �00000023452 12202472000 021332� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME UI::Dialog::Backend::Zenity =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) 2013 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/ascii.pl��������������������������������������������������������������������000644 �000765 �000024 �00000013345 12201404605 017003� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::Backend::ASCII; #sub printerr { 1; } sub printerr { print STDERR 'UI::Dialog : '.join( " ", @_ ); } sub CB_CANCEL { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_CANCEL > ".$func." (This is executed when the user presses the CANCEL button.)\n"); } sub CB_OK { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_OK > ".$func." (This is executed when the user presses the OK button.)\n"); } sub CB_ESC { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_ESC > ".$func." (This is executed when the user presses the ESC button.)\n"); } sub CB_PRE { my $args = shift(); my $func = $args->{'caller'}; sleep(1); # we wait for a second so that the user can digest STDERR before the next widget... printerr("CB_PRE > ".$func." (This is executed before any widget does anything.)\n"); } sub CB_POST { my $args = shift(); my $func = $args->{'caller'}; my $state = shift()||'NULL'; printerr("CB_POST > ".$func." > ".$state." (This is executed after any widget has completed it's run.)\n"); } my $d = new UI::Dialog::Backend::ASCII ( title => "UI::Dialog::Backend::ASCII Demo", debug => 0, height => 20, width => 65, listheight => 10, callbacks => { CANCEL => \&CB_CANCEL, ESC => \&CB_ESC, OK => \&CB_OK, PRE => \&CB_PRE, POST => \&CB_POST } ); sub CALLBACK_TEST { $d->msgbox( title => '$d->msgbox()', text => 'This is a test of the callback functionality. '. 'On the console STDERR output you should see "CB_PRE > main::CALLBACK_TEST". '. 'This is because this msgbox() widget has been called from a function named CALLBACK_TEST.' ); } CALLBACK_TEST(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->infobox( title => '$d->infobox', timeout => 6000, text => 'This is the infobox widget. '. 'There should be no buttons below this text message, '. 'the title of this message box should be "$d->infobox()", ' . 'and this should disappear after 6 seconds.' ); $d->msgbox( title => '$d->msgbox()', text => 'This is the msgbox widget. ' . 'There should be a prompt below this text message informing you to ' . '[ Press Enter To Continue ], ' . 'and the title of this message box should be "$d->msgbox()".' ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if ($d->yesno( title => '$d->yesno()', text => 'This is a question widget. '. 'There should be a prompt below this text message '. 'indicating (Yes|no) (the one with the capital letter is the default for ' . 'when you enter nothing), ' . 'and the title of this message box should be "$d->yesno()".' )) { printerr("The user has answered YES to the yesno widget.\n"); } else { printerr("The user has answered NO to the yesno widget.\n"); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ foreach my $i (20,40,60,80,100) { last unless $d->draw_gauge( text => "gauge message. Current: ".$i, percent => $i ); sleep(1); } $d->end_gauge(); # foreach my $i (100,1000,2000,6000,9000,12345) { # last unless $d->draw_gauge( bar => "-", mark => "|", length => 74, # current => $i, total => 12345 ); # sleep(1); # } # $d->end_gauge(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ print STDOUT "spinner... "; for (20,40,60,80,100) { print $d->spinner(); sleep(1); } print STDOUT "\bdone.\n"; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $inputbox = $d->inputbox( title => '$d->inputbox()', text => 'Please enter some text below:', entry => 'preset text entry' ); if ($d->state() eq "OK") { print "You input: ".($inputbox||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $password = $d->password( title => '$d->password()', text => 'Please input text below: (text should be hidden)' ); if ($d->state() eq "OK") { print "You input: ".($password||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->textbox( title => '$d->textbox()', path => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $menuSelect = $d->menu( title => '$d->menu()', text=>'select:', list => [ 'Test', 'testing', 'ASCII', 'ascii' ] ); if ($d->state() eq "OK") { print "You selected: '".($menuSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @checkSelect = $d->checklist( title => '$d->checklist()', text => 'select:', list => [ 'Test', [ 'testing', 1 ], 'ASCII', [ 'ascii', '0' ] ] ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@checkSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $radioSelect = $d->radiolist( title => '$d->radiolist()', text => 'select:', list =>[ 'test', [ 'testing', 0 ], 'ASCII', [ 'ascii', 1 ] ]); if ($d->state() eq "OK") { print "You selected: '".$radioSelect."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dirname = $d->dselect( title => '$d->dselect()', path => "/" ); if ($d->state() eq "OK") { print "You selected: '".$dirname."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $filename = $d->fselect( title => '$d->fselect()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$filename."'\n"; } exit(); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/cdialog.pl������������������������������������������������������������������000644 �000765 �000024 �00000014265 12201404605 017317� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::Backend::CDialog; sub printerr { print STDERR 'UI::Dialog : '.join( " ", @_ ); } sub CB_CANCEL { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_CANCEL > ".$func." (This is executed when the user presses the CANCEL button.)\n"); } sub CB_OK { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_OK > ".$func." (This is executed when the user presses the OK button.)\n"); } sub CB_ESC { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_ESC > ".$func." (This is executed when the user presses the ESC button.)\n"); } sub CB_PRE { my $args = shift(); my $func = $args->{'caller'}; sleep(1); printerr("CB_PRE > ".$func." (This is executed before any widget does anything.)\n"); } sub CB_POST { my $args = shift(); my $func = $args->{'caller'}; my $state = shift()||'NULL'; printerr("CB_POST > ".$func." > ".$state." (This is executed after any widget has completed it's run.)\n"); } my $d = new UI::Dialog::Backend::CDialog ( title => "UI::Dialog::Backend::CDialog Demo", debug => 1, height => 20, width => 65, callbacks => { CANCEL => \&CB_CANCEL, ESC => \&CB_ESC, OK => \&CB_OK, PRE => \&CB_PRE, POST => \&CB_POST } ); sub CALLBACK_TEST { $d->msgbox( title => '$d->msgbox()', text => 'This is a test of the callback functionality. '. 'On the console STDERR output you should see "CB_PRE > main::CALLBACK_TEST". '. 'This is because this msgbox() widget has been called from a function named CALLBACK_TEST.' ); } CALLBACK_TEST(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->msgbox( title => '$d->msgbox()', text => 'This is the msgbox widget. ' . 'There should be a single "OK" button below this text message, ' . 'and the title of this message box should be "$d->msgbox()".' ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if ($d->yesno( title => '$d->yesno()', text => 'This is a question widget. '. 'There should be "OK" and "CANCEL" buttons below this text message. '. 'and the title of this message box should be "$d->yesno()".' )) { printerr("The user has answered YES to the yesno widget.\n"); } else { printerr("The user has answered NO to the yesno widget.\n"); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->infobox( timeout => 6000, title => '$d->infobox()', text => 'This is an infobox widget. '. 'There should be an "OK" button below this message, '. 'and the title of this info box should be "$d->infobox()". '. 'This will self destruct in 6 seconds.'); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->gauge_start( title => '$d->gauge_start()', text => 'This is a gauge indicator.' ); foreach my $i (20,40,60,80,100) { last unless $d->gauge_set($i); sleep(1); } $d->gauge_stop(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $inputbox = $d->inputbox( title => '$d->inputbox()', text => 'Please enter some text below:', entry => 'preset text entry' ); if ($d->state() eq "OK") { print "You input: ".($inputbox||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $password = $d->password( title => '$d->password()', text => 'Please input text below: (text should be hidden)' ); if ($d->state() eq "OK") { print "You input: ".($password||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->textbox( title => '$d->textbox()', path => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $menuSelect = $d->menu( title => '$d->menu()', text=>'select:', list => [ 'Test', 'testing', 'CD', 'CDialog' ] ); if ($d->state() eq "OK") { print "You selected: '".($menuSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @checkSelect = $d->checklist( title => '$d->checklist()', text => 'select:', list => [ 'Test', [ 'testing', 1 ], 'CD', [ 'CDialog', '0' ] ] ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@checkSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $radioSelect = $d->radiolist( title => '$d->radiolist()', text => 'select:', list =>[ 'test', [ 'testing', 0 ], 'CD', [ 'CDialog', 1 ] ]); if ($d->state() eq "OK") { print "You selected: '".$radioSelect."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dirname = $d->dselect( title => '$d->dselect()', height => 10, path => "/" ); if ($d->state() eq "OK") { print "You selected: '".$dirname."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $filename = $d->fselect( title => '$d->fselect()', height => 10, path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$filename."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->tailbox( title => '$d->tailbox()', filename => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my ($sec, $min, $hour, $day, $month, $year) = localtime(time()); my $timeSelect = $d->timebox( text => 'select:', height => 5, second => $sec, minute => $min, hour => $hour ); my @time = $d->ra(); if ($d->state() eq "OK") { print "You selected: '".($timeSelect||'NULL')."' or rather: ".$time[0]." hour, ".$time[1]." minute, ".$time[2]." second.\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dateSelect = $d->calendar( title => '$d->calendar()', day => $day, month => $month, height => 5, year => ($year + 1900) ); my @date = $d->ra(); if ($d->state() eq "OK") { print "You selected: '".($dateSelect||'NULL')."' or rather: ".$date[0]." day, ".$date[1]." month, ".$date[2]." year.\n"; } exit(); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/console.pl������������������������������������������������������������������000644 �000765 �000024 �00000000523 12201404605 017347� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use FileHandle; use UI::Dialog::Console; my $d = new UI::Dialog::Console ( title => "UI::Dialog::Console Demo", debug => 0, height => 20, width => 65 ); $d->msgbox( text => "This message box is provided by one of the following: dialog, whiptail, or simple ASCII." ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/gdialog.pl������������������������������������������������������������������000644 �000765 �000024 �00000012400 12201404605 017310� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::Backend::GDialog; sub printerr { print STDERR 'UI::Dialog : '.join( " ", @_ ); } sub CB_CANCEL { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_CANCEL > ".$func." (This is executed when the user presses the CANCEL button.)\n"); } sub CB_OK { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_OK > ".$func." (This is executed when the user presses the OK button.)\n"); } sub CB_ESC { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_ESC > ".$func." (This is executed when the user presses the ESC button.)\n"); } sub CB_PRE { my $args = shift(); my $func = $args->{'caller'}; sleep(1); # we wait for a second so that the user can digest STDERR before the next widget... printerr("CB_PRE > ".$func." (This is executed before any widget does anything.)\n"); } sub CB_POST { my $args = shift(); my $func = $args->{'caller'}; my $state = shift()||'NULL'; printerr("CB_POST > ".$func." > ".$state." (This is executed after any widget has completed it's run.)\n"); } my $d = new UI::Dialog::Backend::GDialog ( title => "UI::Dialog::Backend::GDialog Demo", debug => 0, height => 20, width => 65, listheight => 10, callbacks => { CANCEL => \&CB_CANCEL, ESC => \&CB_ESC, OK => \&CB_OK, PRE => \&CB_PRE, POST => \&CB_POST } ); sub CALLBACK_TEST { $d->msgbox( title => '$d->msgbox()', text => 'This is a test of the callback functionality. '. 'On the console STDERR output you should see "CB_PRE > main::CALLBACK_TEST". '. 'This is because this msgbox() widget has been called from a function named CALLBACK_TEST.' ); } CALLBACK_TEST(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->infobox( title => '$d->infobox', timeout => 6000, text => 'This is the infobox widget. '. 'There should be no buttons below this text message, '. 'the title of this message box should be "$d->infobox()", ' . 'and this should disappear after 6 seconds.' ); $d->msgbox( title => '$d->msgbox()', text => [ 'This is the msgbox widget. ' . 'There should be a single "OK" button below this text message, ' . 'and the title of this message box should be "$d->msgbox()".' ] ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if ($d->yesno( title => '$d->yesno()', text => 'This is a question widget. '. 'There should be "OK" and "CANCEL" buttons below this text message. '. 'and the title of this message box should be "$d->yesno()".' )) { printerr("The user has answered YES to the yesno widget.\n"); } else { printerr("The user has answered NO to the yesno widget.\n"); } # #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # $d->gauge_start( title => '$d->gauge_start()', # text => 'This is a progress indicator.' ); # foreach my $i (20,40,60,80,100) { # last unless $d->gauge_set($i); # sleep(1); # } # $d->gauge_stop(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $inputbox = $d->inputbox( title => '$d->inputbox()', text => 'Please enter some text below:', entry => 'preset text entry' ); if ($d->state() eq "OK") { print "You input: ".($inputbox||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $password = $d->password( title => '$d->password()', text => 'Please input text below: (text should be hidden)' ); if ($d->state() eq "OK") { print "You input: ".($password||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->textbox( title => '$d->textbox()', path => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $menuSelect = $d->menu( title => '$d->menu()', text=>'select:', list => [ 'Test', 'testing', 'Gd', 'gdialog' ] ); if ($d->state() eq "OK") { print "You selected: '".($menuSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @checkSelect = $d->checklist( title => '$d->checklist()', text => 'select:', list => [ 'Test', [ 'testing', 1 ], 'Gd', [ 'gdialog', '0' ] ] ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@checkSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $radioSelect = $d->radiolist( title => '$d->radiolist()', text => 'select:', list =>[ 'test', [ 'testing', 0 ], 'Gd', [ 'gdialog', 1 ] ]); if ($d->state() eq "OK") { print "You selected: '".$radioSelect."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dirname = $d->dselect( title => '$d->dselect()', path => "/" ); if ($d->state() eq "OK") { print "You selected: '".$dirname."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $filename = $d->fselect( title => '$d->fselect()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$filename."'\n"; } exit(); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/gnome.pl��������������������������������������������������������������������000644 �000765 �000024 �00000000504 12201404605 017011� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use FileHandle; use UI::Dialog::GNOME; my $d = new UI::Dialog::GNOME ( title => "UI::Dialog::GNOME Demo", debug => 0, height => 20, width => 65 ); $d->msgbox( text => "This message box is provided by one of the following: zenity, Xdialog or gdialog." ); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/kde.pl����������������������������������������������������������������������000644 �000765 �000024 �00000000447 12201404605 016455� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::KDE; my $d = new UI::Dialog::KDE ( title => "UI::Dialog::KDE Demo", debug => 0, height => 20, width => 65 ); $d->msgbox( text => "This message box is provided by one of the following: kdialog or Xdialog." ); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/kdialog.pl������������������������������������������������������������������000644 �000765 �000024 �00000015737 12201404605 017334� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::Backend::KDialog; sub printerr { print STDERR 'UI::Dialog : '.join( " ", @_ ); } sub CB_CANCEL { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_CANCEL > ".$func." (This is executed when the user presses the CANCEL button.)\n"); } sub CB_OK { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_OK > ".$func." (This is executed when the user presses the OK button.)\n"); } sub CB_ESC { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_ESC > ".$func." (This is executed when the user presses the ESC button.)\n"); } sub CB_PRE { my $args = shift(); my $func = $args->{'caller'}; sleep(1); # we wait for a second so that the user can digest STDERR before the next widget... printerr("CB_PRE > ".$func." (This is executed before any widget does anything.)\n"); } sub CB_POST { my $args = shift(); my $func = $args->{'caller'}; my $state = shift()||'NULL'; printerr("CB_POST > ".$func." > ".$state." (This is executed after any widget has completed it's run.)\n"); } my $d = new UI::Dialog::Backend::KDialog ( title => "UI::Dialog::Backend::KDialog Demo", debug => 0, height => 20, width => 65, listheight => 10, callbacks => { CANCEL => \&CB_CANCEL, ESC => \&CB_ESC, OK => \&CB_OK, PRE => \&CB_PRE, POST => \&CB_POST } ); sub CALLBACK_TEST { $d->msgbox( title => '$d->msgbox()', text => 'This is a test of the callback functionality. '. 'On the console STDERR output you should see "CB_PRE > main::CALLBACK_TEST". '. 'This is because this msgbox() widget has been called from a function named CALLBACK_TEST.' ); } CALLBACK_TEST(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->msgbox( title => '$d->msgbox()', text => 'This is the msgbox widget. ' . 'There should be a single "OK" button below this text message, ' . 'and the title of this message box should be "$d->msgbox()".' ); $d->sorry( title => '$d->sorry()', text => 'This is the sorry widget. ' . 'There should be a single "OK" button below this text message, ' . 'and the title of this message box should be "$d->sorry()".' ); $d->error( title => '$d->error()', text => 'This is the error widget. ' . 'There should be a single "OK" button below this text message, ' . 'and the title of this message box should be "$d->error()".' ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if ($d->yesno( title => '$d->yesno()', text => 'This is a question widget. '. 'There should be "YES" and "NO" buttons below this text message. '. 'and the title of this message box should be "$d->yesno()".' )) { printerr("The user has answered YES to the yesno widget.\n"); } else { printerr("The user has answered NO to the yesno widget.\n"); } if ($d->yesnocancel( title => '$d->yesnocancel()', text => 'This is a question widget. '. 'There should be "YES", "NO" and "CANCEL" buttons below this text message. '. 'and the title of this message box should be "$d->yesnocancel()".' )) { printerr("The user has answered YES to the yesnocancel widget.\n"); } else { printerr("The user has answered NO to the yesnocancel widget.\n"); } if ($d->warningyesno( title => '$d->warningyesno()', text => 'This is a question widget. '. 'There should be "YES" and "NO" buttons below this text message. '. 'and the title of this message box should be "$d->warningyesno()".' )) { printerr("The user has answered YES to the warningyesno widget.\n"); } else { printerr("The user has answered NO to the warningyesno widget.\n"); } if ($d->warningyesnocancel( title => '$d->warningyesnocancel()', text => 'This is a question widget. '. 'There should be "YES", "NO" and "CANCEL" buttons below this text message. '. 'and the title of this message box should be "$d->warningyesnocancel()".' )) { printerr("The user has answered YES to the warningyesnocancel widget.\n"); } else { printerr("The user has answered NO to the warningyesnocancel widget.\n"); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $inputbox = $d->inputbox( title => '$d->inputbox()', text => 'Please enter some text below:', entry => 'preset text entry' ); if ($d->state() eq "OK") { print "You input: ".($inputbox||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $password = $d->password( title => '$d->password()', text => 'Please input text below: (text should be hidden)' ); if ($d->state() eq "OK") { print "You input: ".($password||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->textbox( title => '$d->textbox()', path => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $menuSelect = $d->menu( title => '$d->menu()', text=>'select:', list => [ 'Test', 'testing', 'Kd', 'kdialog' ] ); if ($d->state() eq "OK") { print "You selected: '".($menuSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @checkSelect = $d->checklist( title => '$d->checklist()', text => 'select:', list => [ 'Test', [ 'testing', 1 ], 'Kd', [ 'kdialog', '0' ] ] ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@checkSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $radioSelect = $d->radiolist( title => '$d->radiolist()', text => 'select:', list =>[ 'test', [ 'testing', 0 ], 'Kd', [ 'kdialog', 1 ] ]); if ($d->state() eq "OK") { print "You selected: '".$radioSelect."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dirname = $d->getexistingdirectory( title => '$d->getexistingdirectory()', path => "/" ); if ($d->state() eq "OK") { print "You selected: '".$dirname."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $openfilename = $d->getopenfilename( title => '$d->getopenfilename()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$openfilename."'\n"; } my $savefilename = $d->getsavefilename( title => '$d->getopenfilename()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$savefilename."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $openurl = $d->getopenurl( title => '$d->getopenurl()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$openurl."'\n"; } my $saveurl = $d->getsaveurl( title => '$d->getopenurl()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$saveurl."'\n"; } exit(); ���������������������������������UI-Dialog-1.09/examples/nautilus.pl�����������������������������������������������������������������000644 �000765 �000024 �00000000702 12201404605 017550� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::GNOME; my $d = new UI::Dialog::GNOME; my @paths = $d->nautilus->paths(); my @uris = $d->nautilus->uris(); my $path = $d->nautilus->path(); my $uri = $d->nautilus->uri(); my @geo = $d->nautilus->geometry(); $d->msgbox(text=>[ 'paths: '.join(" ",@paths), 'uris: '.join(" ",@uris), 'path: '.$path, 'uri: '.$uri, 'geo: '.join(" ",@geo) ]); ��������������������������������������������������������������UI-Dialog-1.09/examples/screen-menu.pl��������������������������������������������������������������000644 �000765 �000024 �00000001553 12202472000 020125� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/env perl use strict; use warnings; use diagnostics; use constant { TRUE => 1, FALSE => 0 }; use lib qw(./lib); use UI::Dialog::Screen::Menu; # #: Demonstrate usage of UI::Dialog::Screen::Menu # our $counter = 0; my $s = new UI::Dialog::Screen::Menu ( title => "test title", text => "test text", order => [ 'dialog' ] ); $s->add_menu_item ( "An Action ".$counter, sub { my ($self,$dialog,$index) = @_; $counter++; $s->set_menu_item( $index, "An Action ".$counter, undef ); } ); my $s2 = new UI::Dialog::Screen::Menu ( title => "test 2 title", text => "test 2 text", order => [ 'dialog' ] ); $s2->add_menu_item ( "Another Option", sub { my ($self,$dialog,$index) = @_; $dialog->msgbox( text => "Hi" ); } ); $s->add_menu_item ( "Next Screen", sub { $s2->loop(); } ); $s->loop(); exit 0; �����������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/ui-dialog.pl����������������������������������������������������������������000644 �000765 �000024 �00000000537 12201404605 017564� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog; my $d = new UI::Dialog ( title => "UI::Dialog Demo", debug => 0, height => 20, width => 65 ); $d->msgbox( text => [ "This message box is provided by one of the following: zenity, Xdialog or gdialog. ", "(Or if from a console: dialog, whiptail, ascii)" ] ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/whiptail.pl�����������������������������������������������������������������000644 �000765 �000024 �00000012350 12201404605 017527� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::Backend::Whiptail; sub printerr { print STDERR 'UI::Dialog : '.join( " ", @_ ); } sub CB_CANCEL { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_CANCEL > ".$func." (This is executed when the user presses the CANCEL button.)\n"); } sub CB_OK { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_OK > ".$func." (This is executed when the user presses the OK button.)\n"); } sub CB_ESC { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_ESC > ".$func." (This is executed when the user presses the ESC button.)\n"); } sub CB_PRE { my $args = shift(); my $func = $args->{'caller'}; sleep(1); # we wait for a second so that the user can digest STDERR before the next widget... printerr("CB_PRE > ".$func." (This is executed before any widget does anything.)\n"); } sub CB_POST { my $args = shift(); my $func = $args->{'caller'}; my $state = shift()||'NULL'; printerr("CB_POST > ".$func." > ".$state." (This is executed after any widget has completed it's run.)\n"); } my $d = new UI::Dialog::Backend::Whiptail ( title => "UI::Dialog::Backend::Whiptail Demo", debug => 0, height => 20, width => 65, listheight => 10, callbacks => { CANCEL => \&CB_CANCEL, ESC => \&CB_ESC, OK => \&CB_OK, PRE => \&CB_PRE, POST => \&CB_POST } ); sub CALLBACK_TEST { $d->msgbox( title => '$d->msgbox()', text => 'This is a test of the callback functionality. '. 'On the console STDERR output you should see "CB_PRE > main::CALLBACK_TEST". '. 'This is because this msgbox() widget has been called from a function named CALLBACK_TEST.' ); } CALLBACK_TEST(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->infobox( title => '$d->infobox', timeout => 6000, text => 'This is the infobox widget. '. 'There should be no buttons below this text message, '. 'the title of this message box should be "$d->infobox()", ' . 'and this should disappear after 6 seconds.' ); $d->msgbox( title => '$d->msgbox()', text => 'This is the msgbox widget. ' . 'There should be a single "OK" button below this text message, ' . 'and the title of this message box should be "$d->msgbox()".' ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if ($d->yesno( title => '$d->yesno()', text => 'This is a question widget. '. 'There should be "OK" and "CANCEL" buttons below this text message. '. 'and the title of this message box should be "$d->yesno()".' )) { printerr("The user has answered YES to the yesno widget.\n"); } else { printerr("The user has answered NO to the yesno widget.\n"); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->gauge_start( title => '$d->gauge_start()', text => 'This is a progress indicator.' ); foreach my $i (20,40,60,80,100) { last unless $d->gauge_set($i); sleep(1); } $d->gauge_stop(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $inputbox = $d->inputbox( title => '$d->inputbox()', text => 'Please enter some text below:', entry => 'preset text entry' ); if ($d->state() eq "OK") { print "You input: ".($inputbox||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $password = $d->password( title => '$d->password()', text => 'Please input text below: (text should be hidden)' ); if ($d->state() eq "OK") { print "You input: ".($password||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->textbox( title => '$d->textbox()', path => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $menuSelect = $d->menu( title => '$d->menu()', text=>'select:', list => [ 'Test', 'testing', 'Whip', 'whiptail' ] ); if ($d->state() eq "OK") { print "You selected: '".($menuSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @checkSelect = $d->checklist( title => '$d->checklist()', text => 'select:', list => [ 'Test', [ 'testing', 1 ], 'Whip', [ 'whiptail', '0' ] ] ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@checkSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $radioSelect = $d->radiolist( title => '$d->radiolist()', text => 'select:', list =>[ 'test', [ 'testing', 0 ], 'Whip', [ 'whiptail', 1 ] ]); if ($d->state() eq "OK") { print "You selected: '".$radioSelect."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dirname = $d->dselect( title => '$d->dselect()', path => "/" ); if ($d->state() eq "OK") { print "You selected: '".$dirname."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $filename = $d->fselect( title => '$d->fselect()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$filename."'\n"; } exit(); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/xdialog.pl������������������������������������������������������������������000644 �000765 �000024 �00000026124 12201404605 017341� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use FileHandle; use UI::Dialog::Backend::XDialog; sub printerr { print STDERR 'UI::Dialog : '.join( " ", @_ ); } sub CB_CANCEL { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_CANCEL > ".$func." (This is executed when the user presses the CANCEL button.)\n"); } sub CB_OK { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_OK > ".$func." (This is executed when the user presses the OK button.)\n"); } sub CB_ESC { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_ESC > ".$func." (This is executed when the user presses the ESC button.)\n"); } sub CB_PRE { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_PRE > ".$func." (This is executed before any widget does anything.)\n"); } sub CB_POST { my $args = shift(); my $func = $args->{'caller'}; my $state = shift()||'NULL'; printerr("CB_POST > ".$func." > ".$state." (This is executed after any widget has completed it's run.)\n"); } my $d = new UI::Dialog::Backend::XDialog ( title => "UI::Dialog::Backend::Zenity Demo", debug => 1, height => 20, width => 65, callbacks => { CANCEL => \&CB_CANCEL, ESC => \&CB_ESC, OK => \&CB_OK, PRE => \&CB_PRE, POST => \&CB_POST } ); sub CALLBACK_TEST { $d->msgbox( title => '$d->msgbox()', text => 'This is a test of the callback functionality. '. 'On the console STDERR output you should see "CB_PRE > main::CALLBACK_TEST". '. 'This is because this msgbox() widget has been called from a function named CALLBACK_TEST.' ); } CALLBACK_TEST(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->msgbox( title => '$d->msgbox()', text => 'This is the msgbox widget. ' . 'There should be a single "OK" button below this text message, ' . 'and the title of this message box should be "$d->msgbox()".' ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if ($d->yesno( title => '$d->yesno()', text => 'This is a question widget. '. 'There should be "OK" and "CANCEL" buttons below this text message. '. 'and the title of this message box should be "$d->yesno()".' )) { printerr("The user has answered YES to the yesno widget.\n"); } else { printerr("The user has answered NO to the yesno widget.\n"); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->infobox( timeout => 6000, title => '$d->infobox()', text => 'This is an infobox widget. '. 'There should be an "OK" button below this message, '. 'and the title of this info box should be "$d->infobox()". '. 'This will self destruct in 6 seconds.'); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->gauge_start( title => '$d->gauge_start()', text => 'This is a gauge indicator.' ); foreach my $i (20,40,60,80,100) { last unless $d->gauge_set($i); sleep(1); } $d->gauge_stop(); $d->progress_start( title => '$d->progress_start()', text => 'This is a progress indicator.' ); foreach my $i (20,40,60,80,100) { last unless $d->progress_set($i); sleep(1); } $d->progress_stop(); # duality test $d->gauge_start( text => 'gauge...', begin => [ 10, 10 ] ); $d->progress_start( text => 'progress...' ); foreach my $i (20,40,60,80,100) { last unless $d->gauge_set($i); sleep(1); last unless $d->progress_set($i); sleep(1); } $d->gauge_stop(); $d->progress_stop(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $inputbox = $d->inputbox( title => '$d->inputbox()', text => 'Please enter some text below:', entry => 'preset text entry' ); if ($d->state() eq "OK") { print "You input: ".($inputbox||'NULL')."\n"; } #: inputsbox2 my @inputsbox2 = $d->inputsbox2( title => '$d->inputsbox2()', text => 'Please enter some text below:', label1 => 'label1', label2 => 'label2', input1 => 'field1', input2 => 'field2'); if ($d->state() eq "OK") { print "You entered: '".(join("' '",@inputsbox2)||'NULL')."'\n"; } #: inputsbox3 my @inputsbox3 = $d->inputsbox3( title => '$d->inputsbox3()', text => 'Please enter some text below:', label1 => 'label1', label2 => 'label2', label3 => 'label3', input1 => 'field1', input2 => 'field2', input3 => 'field3' ); if ($d->state() eq "OK") { print "You entered: '".(join("' '",@inputsbox3)||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $password = $d->password( title => '$d->password()', text => 'Please input text below: (text should be hidden)' ); if ($d->state() eq "OK") { print "You input: ".($password||'NULL')."\n"; } #: passwords2 my @passwords2 = $d->passwords2(text=>'Please enter some text below: (text should be hidden)', label1=>'label1',label2=>'label2'); if ($d->state() eq "OK") { print "You entered: '".(join("' '",@passwords2)||'NULL')."'\n"; } #: passwords3 my @passwords3 = $d->passwords3(text=>'Please enter some text below: (text should be hidden)', label1=>'label1',label2=>'label2',label3=>'label3'); if ($d->state() eq "OK") { print "You entered: '".(join("' '",@passwords3)||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->textbox( title => '$d->textbox()', path => $0 ); my $editbox = $d->editbox( title => '$d->editbox()', path => $0 ); if ($d->state() eq "OK") { print "Your edited text:\n\n[BEGIN TEXT]\n".($editbox||'NULL')."\n[END TEXT]\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $menuSelect = $d->menu( title => '$d->menu()', text=>'select:', list => [ 'Test', 'testing', 'Xd', 'XDialog' ] ); if ($d->state() eq "OK") { print "You selected: '".($menuSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @checkSelect = $d->checklist( title => '$d->checklist()', text => 'select:', list => [ 'Test', [ 'testing', 1 ], 'Xd', [ 'XDialog', '0' ] ] ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@checkSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $radioSelect = $d->radiolist( title => '$d->radiolist()', text => 'select:', list =>[ 'test', [ 'testing', 0 ], 'Xd', [ 'XDialog', 1 ] ]); if ($d->state() eq "OK") { print "You selected: '".$radioSelect."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dirname = $d->dselect( title => '$d->dselect()', path => "/" ); if ($d->state() eq "OK") { print "You selected: '".$dirname."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $filename = $d->fselect( title => '$d->fselect()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$filename."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $comboSelect = $d->combobox( editable => 1, title => '$d->combobox()', text => 'select:', list => [ 'test', 'Xdialog' ] ); if ($d->state() eq "OK") { print "You selected: '".($comboSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $rangeSelect = $d->rangebox( title => '$d->rangebox()', text => 'set:', min => 10, max => 100, def => 54 ); if ($d->state() eq "OK") { print "You selected: '".($rangeSelect||'NULL')."'\n"; } my @rangeSelect2 = $d->rangesbox2( text => 'set:', title => '$d->rangesbox2()', label1 => 'one', min1 => 10, max1 => 100, def1 => 54, label2 => 'two', min2 => 1, max2 => 10, def2 => 5 ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@rangeSelect2))."'\n"; } my @rangeSelect3 = $d->rangesbox3( text => 'set:', title => '$d->rangesbox3()', label1 => 'one', min1 => 10, max1 => 100, def1 => 54, label2 => 'two', min2 => 1, max2 => 10, def2 => 5, label2 => 'three', min3 => 100, max3 => 1000, def3 => 500 ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@rangeSelect3))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $spinSelect = $d->spinbox( title => '$d->spinbox()', text => 'set:', min => 10, max => 100, def => 54, label1 => 'label' ); if ($d->state() eq "OK") { print "You selected: '".($spinSelect||'null')."'\n"; } my @spinsSelect2 = $d->spinsbox2( text => 'set:', title => '$d->spinsbox2()', label1 => 'one', min1 => 10, max1 => 100, def1 => 54, label2 => 'two', min2 => 1, max2 => 10, def2 => 5); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@spinsSelect2))."'\n"; } my @spinsSelect3 = $d->spinsbox3( text => 'set:', title => '$d->spinsbox3()', label1 => 'one', min1 => 10, max1 => 100, def1 => 54, label2 => 'two', min2 => 1, max2 => 10, def2 => 5, label2 => 'three', min3 => 100, max3=> 1000, def3 => 500 ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@spinsSelect3))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->tailbox( title => '$d->tailbox()', filename => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->logbox( title => '$d->logbox()', filename => $0 ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @buildSelect = $d->buildlist(text=>'select:', list=>['test',['testing',1], 'Xd',['Xdialog',0], 'more',['much more',1]]); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@buildSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $treeSelect = $d->treeview(text=>'select:', list=>['r1',['root',1,1], 'b1',['branch1',1,2], 'b2',['branch2',1,2], 'r2',['another root',1,1], 'b3',['branch3',1,2], 's1',['subbranch1',1,3] ]); if ($d->state() eq "OK") { print "You selected: '".($treeSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my ($sec, $min, $hour, $mday, $month, $year, $wday, $yday, $isdst) = localtime(time()); my $timeSelect = $d->timebox( text => 'select:', height => 11, second => $sec, minute => $min, hour => $hour ); my @time = $d->ra(); if ($d->state() eq "OK") { print "You selected: '".($timeSelect||'NULL')."' or rather: ".$time[0]." hour, ".$time[1]." minute, ".$time[2]." second.\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dateSelect = $d->calendar( title => '$d->calendar()', height => 14, day => $mday, month => $month, year => ($year + 1900) ); my @date = $d->ra(); if ($d->state() eq "OK") { print "You selected: '".($dateSelect||'NULL')."' or rather: ".$date[0]." day, ".$date[1]." month, ".$date[2]." year.\n"; } exit(); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/xosd.pl���������������������������������������������������������������������000644 �000765 �000024 �00000001365 12201404605 016667� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::Backend::XOSD; my @opts = ( debug => 3, font => "lucidasans-bold-24", # font => "-*-fixed-*-*-*-*-20-*-*-*-*-*-iso8859-*", delay => 2, colour => "green", pos => "middle", align => "center" ); my $d = new UI::Dialog::Backend::XOSD ( @opts ); $d->display_start(); $d->display_text("this is a test"); sleep(1); $d->display_text("so is this"); sleep(1); $d->display_gauge( 25, "even testing a gauge!" ); $d->display_stop(); $d->line( text => "this is a line test" ); $d->gauge( text => "gauging something", percent => "45" ); $d->gauge( text => "gauging something again", percent => "85" ); $d->file( file => $0, lines => 5, indent => 5, align => 'left' ); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������UI-Dialog-1.09/examples/zenity.pl�������������������������������������������������������������������000644 �000765 �000024 �00000014573 12201404605 017241� 0����������������������������������������������������������������������������������������������������ustar�00onest8��������������������������staff���������������������������000000 �000000 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use strict; use warnings; use diagnostics; use UI::Dialog::Backend::Zenity; sub printerr { print STDERR 'UI::Dialog : '.join( " ", @_ ); } sub CB_CANCEL { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_CANCEL > ".$func." (This is executed when the user presses the CANCEL button.)\n"); } sub CB_OK { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_OK > ".$func." (This is executed when the user presses the OK button.)\n"); } sub CB_ESC { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_ESC > ".$func." (This is executed when the user presses the ESC button.)\n"); } sub CB_PRE { my $args = shift(); my $func = $args->{'caller'}; printerr("CB_PRE > ".$func." (This is executed before any widget does anything.)\n"); } sub CB_POST { my $args = shift(); my $func = $args->{'caller'}; my $state = shift()||'NULL'; printerr("CB_POST > ".$func." > ".$state." (This is executed after any widget has completed it's run.)\n"); } my $d = new UI::Dialog::Backend::Zenity ( title => "UI::Dialog::Backend::Zenity Demo", debug => 0, height => 20, width => 65, callbacks => { CANCEL => \&CB_CANCEL, ESC => \&CB_ESC, OK => \&CB_OK, PRE => \&CB_PRE, POST => \&CB_POST } ); sub CALLBACK_TEST { $d->msgbox( title => '$d->msgbox()', text => 'This is a test of the callback functionality. '. 'On the console STDERR output you should see "CB_PRE > main::CALLBACK_TEST". '. 'This is because this msgbox() widget has been called from a function named CALLBACK_TEST.' ); } CALLBACK_TEST(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->msgbox( title => '$d->msgbox()', text => 'This is the msgbox widget. ' . 'There should be a single "OK" button below this text message, ' . 'a lightbulb icon to the left of this text message, ' . 'and the title of this message box should be "$d->msgbox()".' ); $d->warning( title => '$d->warning()', text => 'This is the warning widget. ' . 'There should be "OK" and "CANCEL" buttons below this text message, ' . 'a warning icon to the left of this text message, ' . 'and the title of this message box should be "$d->warning()".' ); $d->error( title => '$d->error()', text => 'This is the error widget. ' . 'There should be a single "OK" button below this text message, ' . 'an error icon to the left of this text message ' . 'and the title of this message box should be "$d->error()".' ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if ($d->yesno( title => '$d->yesno()', text => 'This is a question widget. '. 'There should be "OK" and "CANCEL" buttons below this text message. '. 'a question mark icon to the left of this text message ' . 'and the title of this message box should be "$d->yesno()".' )) { printerr("The user has answered YES to the yesno widget.\n"); } else { printerr("The user has answered NO to the yesno widget.\n"); } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->gauge_start( title => '$d->gauge_start()', text => 'This is a progress indicator.' ); foreach my $i (20,40,60,80,100) { last unless $d->gauge_set($i); sleep(1); } $d->gauge_stop(); $d->gauge_start( title => '$d->gauge_start() #pulsate', pulsate => 1, text => 'This is a pulsating progress indicator.' ); foreach my $i (20,40,60,80,100) { last unless $d->gauge_set($i); sleep(1); } $d->gauge_stop(); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $inputbox = $d->inputbox( title => '$d->inputbox()', text => 'Please enter some text below:', entry => 'preset text entry' ); if ($d->state() eq "OK") { print "You input: ".($inputbox||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $password = $d->password( title => '$d->password()', text => 'Please input text below: (text should be hidden)' ); if ($d->state() eq "OK") { print "You input: ".($password||'NULL')."\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $d->textbox( title => '$d->textbox()', path => $0 ); my $editbox = $d->editbox( title => '$d->editbox()', path => $0 ); if ($d->state() eq "OK") { print "Your edited text:\n\n[BEGIN TEXT]\n".($editbox||'NULL')."\n[END TEXT]\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $menuSelect = $d->menu( title => '$d->menu()', text=>'select:', list => [ 'Test', 'testing', 'Zen', 'zenity' ] ); if ($d->state() eq "OK") { print "You selected: '".($menuSelect||'NULL')."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my @checkSelect = $d->checklist( title => '$d->checklist()', text => 'select:', list => [ 'Test', [ 'testing', 1 ], 'Zen', [ 'zenity', '0' ] ] ); if ($d->state() eq "OK") { print "You selected: '".(join("' '",@checkSelect))."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $radioSelect = $d->radiolist( title => '$d->radiolist()', text => 'select:', list =>[ 'test', [ 'testing', 0 ], 'Zen', [ 'zenity', 1 ] ]); if ($d->state() eq "OK") { print "You selected: '".$radioSelect."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $dirname = $d->dselect( title => '$d->dselect()', path => "/" ); if ($d->state() eq "OK") { print "You selected: '".$dirname."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $filename = $d->fselect( title => '$d->fselect()', path => $dirname ); if ($d->state() eq "OK") { print "You selected: '".$filename."'\n"; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my ($sec, $min, $hour, $mday, $month, $year, $wday, $yday, $isdst) = localtime(time()); my $dateSelect = $d->calendar( title => '$d->calendar()', height => 14, day => $mday, month => $month, year => ($year + 1900) ); my @date = $d->ra(); if ($d->state() eq "OK") { print "You selected: '".($dateSelect||'NULL')."' or rather: ".$date[0]." day, ".$date[1]." month, ".$date[2]." year.\n"; } exit(); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������