libcurses-widgets-perl-1.997.orig/0000755000175000017500000000000010021050434016544 5ustar srzsrz00000000000000libcurses-widgets-perl-1.997.orig/CHANGELOG0000644000175000017500000000730607564777111020016 0ustar srzsrz00000000000000---------------------------- revision 1.997 locked by: corliss; date: 2002/11/14 01:30:19; author: corliss; state: Exp; lines: +34 -7 --POD fixes --Compatibility fix for curses without attr_get/attr_set functions --Introduction of the multi-column list box ListBox: --Fixed VALUE initialisation bug when when in multi-select mode --Fixed cursor position bug for large jumps down the last (past the viewable window) --Changed arrow placement to go by window bounds to make inherited behaviour more predictable --Added printable character navigation (thanks to Eric Lenio) Menu: --Checking for defined code reference before attempting to execute TextMemo: --Changed arrow placement to go by window bounds to make inherited behaviour more predictable ---------------------------- revision 1.996 locked by: corliss; date: 2002/11/03 23:25:01; author: corliss; state: Exp; lines: +450 -75 --Added test_colour function --Added DEFAULTFG and DEFAULTBG scalars --Removed hard coded black:white colour pair, now detecting actual colours --select_colour now correctly applies terminal default bg colour rather than black --select_colour now accepts any case of colour strings --_conf method now applies terminal defaults to all standard colour keys --draw method is now a standard handler for all widgets, content printing is now done in _content and _cursor --Border and captions are handled by default in Widgets.pm now, with _border and _caption --Content is now drawn in it's own private derived window, removing any need to adjust coordinates for a border --Added _geometry, _cgeometry, and _canvas methods --Added _save and _restore to save the window default colours and attributes --Fixed a few bugs in how textwrap handled and returned trailing newlines --Changed LENGTH attribute to COLUMNS in applicable widgets --Removed touchwin calls for more efficient refresh --Newlines no longer count as a character space in textwrap All Widgets: --Removed undef colour keys --Reworked to work with new Widgets.pm internals Calendar: --Added header colour selection support --VALUE now holds the date the cursor is on in the current calendar ComboBox: --Fixed bug to allow a user not to select something from the list ListBox: --Entire widget is now underlined correctly in non-borderd mode --VALUE now holds selected items instead of SELECTED TextField & TextMemo: --Fixed underline mode to correctly underline entire field, instead of just text --Added regex to accept only printable characters as part of the value --Fixed bugs in cursor placement and scrolling ---------------------------- revision 1.995 locked by: corliss; date: 2002/10/22 18:00:23; author: corliss; --Added Menu and Label widgets --Auto-applying the list length based on list entries was getting lost at times in the ComboBox. Fixed. --Popup wouldn't show up in the right location on combos on newwins that didn't start at 0,0. Fixed. --VALUE in ListBox wasn't getting updated. Fixed. ---------------------------- revision 1.994 date: 2002/10/22 17:56:08; author: corliss; --Added shift+tab support for execute method --Pod updates ---------------------------- revision 1.993 date: 2002/10/16 06:05:04; author: corliss; --Fix for empty lines in textwrap --Changed _input to input_key --Various style changes --Added callback capabilities for year/month/day changes in Calendar ---------------------------- revision 1.100 date: 2001/12/10 10:56:20; author: corliss; --Documentation updates --Using Carp --Fixed bug that wasn't getting all of the field values in getField ---------------------------- revision 1.99 date: 2001/12/05 09:52:40; author: corliss; --Initial revision of new OO class ============================================================================= libcurses-widgets-perl-1.997.orig/CREDITS0000644000175000017500000000123107564777111017613 0ustar srzsrz00000000000000Credits (Alphabetically listed): ================================ --Eric Lenio : for suggesting and providing a working implementation of the key navigation feature in the ListBox. --Rodrigo Bernardo Pimentel : improvements to the scankey function. --Anthony Rumble : for a continuous stream of ideas for improvements, catching what I missed, and prototyping new widgets. . . --Michael E. Schechter : contributed code for internal generation of the Unix 'cal' command. --Credit has to be given, as always, to Larry Wall, for starting this train a-rolling. :-) libcurses-widgets-perl-1.997.orig/LICENSE0000644000175000017500000004307607014754351017604 0ustar srzsrz00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, 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 or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's 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 give any other recipients of the Program a copy of this License along with the Program. 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 Program or any portion of it, thus forming a work based on the Program, 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) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, 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 Program, 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 Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) 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; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, 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 executable. However, as a special exception, the source code 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. If distribution of executable or 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 counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program 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. 5. 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 Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program 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 to this License. 7. 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 Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program 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 Program. 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. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program 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. 9. The Free Software Foundation may publish revised and/or new versions of the 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 Program 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 Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, 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 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "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 PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. 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 PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. 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) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. libcurses-widgets-perl-1.997.orig/MANIFEST0000644000175000017500000000051407564777216017735 0ustar srzsrz00000000000000Widgets.pm Widgets/ButtonSet.pm Widgets/Calendar.pm Widgets/ComboBox.pm Widgets/Label.pm Widgets/ListBox.pm Widgets/ListBox/MultiColumn.pm Widgets/Menu.pm Widgets/ProgressBar.pm Widgets/TextField.pm Widgets/TextMemo.pm Widgets/Tutorial.pod Widgets/Tutorial/Creation.pod Makefile.PL test.pl CHANGELOG README LICENSE MANIFEST CREDITS libcurses-widgets-perl-1.997.orig/Makefile.PL0000644000175000017500000000047007564777111020551 0ustar srzsrz00000000000000use ExtUtils::MakeMaker; %mods = ( Curses => 1.06, ); WriteMakefile( NAME => 'Curses::Widgets', AUTHOR => 'Arthur Corliss ', ABSTRACT => 'High level access to widgets for rapid interface design.', VERSION => '1.997', PREREQ_PM => \%mods ); libcurses-widgets-perl-1.997.orig/README0000644000175000017500000000207407564777111017461 0ustar srzsrz00000000000000Curses::Widgets Module for Perl ============================== Author: Arthur Corliss Date: December 5, 2001 Description: ------------ High level access to basic Curses widgets and related functions. NOTE: This is **NOT** backwards compatible with the pre-1.99 versions. This is entirely OO-based, hence any older scripts relying on the old versions will need to be rewritten. Also note that certain "widgets" are no longer available (i.e., the dialogs). Those are more properly forms, not widgets, and hence are available in the latest Curses::Forms release. Requirements: ------------- --(n)Curses libraries --Curses module Instructions: ------------- All that one needs to do is: perl Makefile.pl make test make install Documentation for using the module(s) is available if one types the following: perldoc Curses::Widgets There is also a tutorial for creating custom widgets, which can be accessed via: perldoc Curses::Widgets::Tutorial If you find any value in these modules, write me! All hints, tips, and wishes are welcome at corliss@digitalmages.com. libcurses-widgets-perl-1.997.orig/Widgets/0000755000175000017500000000000010021050434020152 5ustar srzsrz00000000000000libcurses-widgets-perl-1.997.orig/Widgets/ButtonSet.pm0000644000175000017500000002174407564777120022501 0ustar srzsrz00000000000000# Curses::Widgets::ButtonSet.pm -- Button Set Widgets # # (c) 2001, Arthur Corliss # # $Id: ButtonSet.pm,v 1.103 2002/11/03 23:31:26 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::ButtonSet - Button Set Widgets =head1 MODULE VERSION $Id: ButtonSet.pm,v 1.103 2002/11/03 23:31:26 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::ButtonSet; $btns = Curses::Widgets::ButtonSet->({ LENGTH => 10, VALUE => 0, INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t\n", HORIZONTAL => 1, PADDING => 1, X => 1, Y => 1, LABELS => [qw(OK CANCEL)], }); $btns->draw($mwh, 1); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =back =head1 DESCRIPTION Curses::Widgets::ButtonSet provides simplified OO access to Curses-based button sets. Each object maintains it's own state information. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::ButtonSet; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; ($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $btns = Curses::Widgets::ButtonSet->({ LENGTH => 10, VALUE => 0, INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t\n", HORIZONTAL => 1, PADDING => 1, X => 1, Y => 1, LABELS => [qw(OK CANCEL)], }); The new method instantiates a new ButtonSet object. The only mandatory key/value pairs in the configuration hash are B, B, and B. All others have the following defaults: Key Default Description ============================================================ LENGTH 10 Number of columns for each button label VALUE 0 Button selected (0-based indexing) INPUTFUNC \&scankey Function to use to scan for keystrokes FOREGROUND undef Default foreground colour BACKGROUND undef Default blackground colour BORDER 1 Display border around the set BORDERCOL undef Foreground colour for border FOCUSSWITCH "\t\n" Characters which signify end of input HORIZONTAL 1 Horizontal orientation for set PADDING 1 Number of spaces between buttons The last option, B, is only applicable to horizontal sets without borders. =cut sub _conf { # Validates and initialises the new TextField object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( LENGTH => 10, VALUE => 0, INPUTFUNC => \&scankey, BORDER => 1, FOCUSSWITCH => "\t\n", HORIZONTAL => 1, PADDING => 1, @_ ); my @required = qw(X Y LABELS); my $err = 0; my ($cols, $lines, $i); # Check for required arguments foreach (@required) { $err = 1 unless exists $conf{$_} }; # Calculate the derived window dimensions $conf{LENGTH} += 2 unless $conf{BORDER}; if ($conf{HORIZONTAL}) { $cols = $conf{LENGTH} * @{$conf{LABELS}}; $i = 0; $i += $conf{PADDING} if ($conf{PADDING} && ! $conf{BORDER}); $i++ if $conf{BORDER}; $cols += (@{$conf{LABELS}} - 1) * $i; $lines = 1; } else { $cols = $conf{LENGTH}; $lines = @{$conf{LABELS}}; $lines += $conf{BORDER} ? @{$conf{LABELS}} - 1 : (@{$conf{LABELS}} - 1) * $conf{PADDING}; } $conf{COLUMNS} = $cols; $conf{LINES} = $lines; # Make sure the parent class didn't generate any errors $err = 1 unless $self->SUPER::_conf(%conf); return $err == 0 ? 1 : 0; } =head2 draw $btns->draw($mwh, 1); The draw method renders the button set in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the set's selected button to be rendered in standout mode (inverse video). =cut sub _border { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($y, $x, $hz, $value, $length, $cols, $lines) = @$conf{qw(Y X HORIZONTAL VALUE LENGTH COLUMNS LINES)}; my @labels = @{ $$conf{LABELS} }; my $border = $$conf{BORDER}; my ($i, $j, $l); # Draw the border if ($border) { if (defined $$conf{BORDERCOL}) { $dwh->attrset(COLOR_PAIR( select_colour(@$conf{qw(BORDERCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{BORDERCOL} eq 'yellow'; } $dwh->box(ACS_VLINE, ACS_HLINE); if ($hz) { $i = $length + 1; until ($i > $cols) { $dwh->addch(0, $i, ACS_TTEE); $dwh->addch(1, $i, ACS_VLINE); $dwh->addch(2, $i, ACS_BTEE); $i += ($length + 1); } } else { $i = 2; until ($i > $lines) { $dwh->addch($i, 0, ACS_LTEE); for ($j = 1; $j <= $length; $j++) { $dwh->addch($i, $j, ACS_HLINE) }; $dwh->addch($i, $length + 1, ACS_RTEE); $i += 2; } } $dwh->attroff(A_BOLD); } $self->_restore($dwh); } sub _caption { # We won't be needing this method, and I don't want anyone using it by # accident. } sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($hz, $value, $length) = @$conf{qw(HORIZONTAL VALUE LENGTH)}; my @labels = @{$$conf{LABELS}}; my ($i, $j, $l, $offset); my $z = 0; # Enforce a sane cursor position if ($$conf{VALUE} > $#labels) { $$conf{VALUE} = $#labels; } elsif ($$conf{VALUE} < 0) { $$conf{VALUE} = 0; } # Calculate the cell offset $offset = $$conf{BORDER} ? 1 : ($$conf{PADDING} ? $$conf{PADDING} : 0); # Draw the labels foreach (@labels) { $_ = substr($_, 0, $length); if (length($_) < $length - 1) { $i = int(($length - length($_)) / 2); unless ($$conf{BORDER}) { $i--; $_ = ' ' x $i . $_ . ' ' x ($length - (length($_) + $i + 2)); $_ = "<$_>"; $i = 0; } } if ($hz) { $dwh->addstr(0, $z + $i, $_); $z += $offset + $length; } else { $dwh->addstr($z, $i, $_); $z += $offset + 1; } } } sub _cursor { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my $label = $$conf{LABELS}->[$$conf{VALUE}]; my ($length, $hz) = @$conf{qw(LENGTH HORIZONTAL)}; my ($y, $x) = (0, 0); my ($offset); # Calculate the cell offset $offset = $$conf{BORDER} ? 1 : ($$conf{PADDING} ? $$conf{PADDING} : 0); # Set the coordinates if ($hz) { $offset = $$conf{VALUE} ? $$conf{VALUE} * $length + $$conf{VALUE} * $offset : 0; $x = $offset; } else { $offset = $$conf{VALUE} ? $$conf{VALUE} + $$conf{VALUE} * $offset : 0; $y = $offset; } # Display the cursor $dwh->chgat($y, $x, $length, A_STANDOUT, select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0); # Restore the default settings $self->_restore($dwh); } sub input_key { # Process input a keystroke at a time. # # Usage: $self->input_key($key); my $self = shift; my $in = shift; my $conf = $self->{CONF}; my ($value, $hz) = @$conf{qw(VALUE HORIZONTAL)}; my $num = scalar @{ $$conf{LABELS} }; if ($hz) { if ($in eq KEY_RIGHT) { ++$value; $value = 0 if $value == $num; } elsif ($in eq KEY_LEFT) { --$value; $value = ($num - 1) if $value == -1; } else { beep; } } else { if ($in eq KEY_UP) { --$value; $value = ($num - 1) if $value == -1; } elsif ($in eq KEY_DOWN) { ++$value; $value = 0 if $value == $num; } else { beep; } } $$conf{VALUE} = $value; } 1; =head1 HISTORY =over =item 1999/12/29 -- Original button set widget in functional model =item 2001/07/05 -- First incarnation in OO architecture =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/Calendar.pm0000644000175000017500000003053107564777120022255 0ustar srzsrz00000000000000# Curses::Widgets::Calendar.pm -- Button Set Widgets # # (c) 2001, Arthur Corliss # # $Id: Calendar.pm,v 1.103 2002/11/03 23:33:05 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::Calendar - Calendar Widgets =head1 MODULE VERSION $Id: Calendar.pm,v 1.103 2002/11/03 23:33:05 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::Calendar; $cal = Curses::Widgets::Calendar->({ CAPTION => 'Appointments', CAPTIONCOL => 'yellow', INPUTFUNC => \&scankey, FOREGROUND => undef, BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t", X => 1, Y => 1, HIGHLIGHT => [12, 17, 25], HIGHLIGHTCOL=> 'green', MONTH => '11/2001', ONYEAR => \&yearly, ONMONTH => \&monthly, ONDAY => \&daily, }); $cal->draw($mwh, 1); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =back =head1 DESCRIPTION Curses::Widgets::Calendar provides simplified OO access to Curses-based calendars. Each object maintains it's own state information. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::Calendar; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; ($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $cal = Curses::Widgets::Calendar->({ CAPTION => 'Appointments', CAPTIONCOL => 'yellow', INPUTFUNC => \&scankey, FOREGROUND => undef, BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t", X => 1, Y => 1, HIGHLIGHT => [12, 17, 25], HIGHLIGHTCOL=> 'green', MONTH => '11/2001', ONYEAR => \&yearly, ONMONTH => \&monthly, ONDAY => \&daily, }); The new method instantiates a new Calendar object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ CAPTION undef Caption superimposed on border CAPTIONCOL undef Foreground colour for caption text INPUTFUNC \&scankey Function to use to scan for keystrokes FOREGROUND undef Default foreground colour BACKGROUND undef Default background colour BORDER 1 Display a border around the field BORDERCOL undef Foreground colour for border FOCUSSWITCH "\t" Characters which signify end of input HIGHLIGHT [] Days to highlight HIGHLIGHTCOL undef Default highlighted data colour HEADERCOL undef Default calendar header colour MONTH (current) Month to display VALUE 1 Day of the month where the cursor is ONYEAR undef Callback function triggered by year ONMONTH undef Callback function triggered by month ONDAY undef Callback function triggered by day Each of the ON* callback functions expect a subroutine reference that excepts one argument: a handle to the calendar object itself. If more than one trigger is called, it will be called in the order of day, month, and then year. =cut sub _conf { # Validates and initialises the new TextField object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( INPUTFUNC => \&scankey, BORDER => 1, FOCUSSWITCH => "\t", HIGHLIGHT => [], VALUE => 1, MONTH => join('/', (localtime)[4] + 1, (localtime)[5] + 1900), LINES => 8, COLUMNS => 20, @_ ); my @required = qw(X Y); my $err = 0; # Check for required arguments foreach (@required) { $err = 1 unless exists $conf{$_} }; # Lowercase all colours foreach (qw(HIGHLIGHTCOL HEADERCOL)) { $conf{$_} = lc($conf{$_}) if exists $conf{$_} }; $err = 1 unless $self->SUPER::_conf(%conf); return $err == 0 ? 1 : 0; } =head2 draw $cal->draw($mwh, 1); The draw method renders the calendar in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the calendar's selected day to be rendered in standout mode (inverse video). =cut sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my $pos = $$conf{VALUE}; my @date = split(/\//, $$conf{MONTH}); my @highlight = @{ $$conf{HIGHLIGHT} }; my ($i, @cal); # Get the calendar lines and print them @cal = _gen_cal(@date[1,0]); $i = 0; foreach (@cal) { # Set the header colour (if defined) unless ($i > 1 || ! exists $$conf{HEADERCOL}) { $dwh->attrset(COLOR_PAIR( select_colour(@$conf{qw(HEADERCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{HEADERCOL} eq 'yellow'; } # Save the cursor position if it's on this line $self->{COORD} = [$i, length($1)] if $cal[$i] =~ /^(.*\b)$pos\b/; # Print the calendar line $dwh->addstr($i, 0, $cal[$i]); # Highlight the necessary dates if (exists $$conf{HIGHLIGHTCOL}) { until ($#highlight == -1 || $cal[$i] !~ /^(.*\b)$highlight[0]\b/) { $dwh->chgat($i, length($1), length($highlight[0]), 0, select_colour(@$conf{qw(HIGHLIGHTCOL BACKGROUND)}), 0); shift @highlight; } } # Restore the default settings (if adjusted for headers or hightlights) $self->_restore($dwh); ++$i; } } sub _cursor { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my $pos = $$conf{VALUE}; my @highlight = @{$$conf{HIGHLIGHT}}; my ($y, $x) = @{$self->{COORD}}; my $fg; # Determine the foreground colour if (exists $$conf{HIGHLIGHTCOL}) { $fg = (grep /^$pos$/, @highlight) ? $$conf{HIGHLIGHTCOL} : $$conf{FOREGROUND}; } else { $fg = $$conf{FOREGROUND}; } # Display the cursor $dwh->chgat($y, $x, length($pos), A_STANDOUT, select_colour($fg, $$conf{BACKGROUND}), 0); # Restore the default settings $self->_restore($dwh); } sub _gen_cal { # Generates the calendar month output, and stuffs it into a # LOL, which is returned by the method. # # Modified from code provided courtesy of Michael E. Schechter, # # # Usage: @lines = $self->_gen_cal($year, $month); my @date = @_; my (@lines, @tmp, $i, @out); # All of these local subroutines are essentially code to replicate # the UNIX 'cal' command. My code parses the output to create the # LOL. local *print_month = sub { my ($year, $month) = @_; my @month = make_month_array($year, $month); my @months = ('', qw(January February March April May June July August September October November December)); my $days = 'Su Mo Tu We Th Fr Sa'; my ($title, $diff, $left, $day, $end, $x, $out); $title = "$months[$month] $year"; $diff = 20 - length($title); $left = $diff - int($diff / 2); $title = ' ' x $left."$title"; $out = "$title\n$days"; $end = 0; for ($x = 0; $x < scalar @month; $x++) { $out .= "\n" if $end == 0; $out .= "$month[$x]"; $end++; if ($end > 6) { $end = 0; } } $out .= "\n"; return $out; }; local *make_month_array = sub { my ($year, $month) = @_; my $firstweekday = day_of_week_num($year, $month, 1); my (@month_array, $numdays, $remain, $x, $y); $numdays = days_in_month($year, $month); $y = 1; for ($x = 0; $x < $firstweekday; $x++ ) { $month_array[$x] = ' ' }; if (! ($year == 1752 && $month == 9)) { for ($x = 1; $x <= $numdays; $x++, $y++) { $month_array[$x + $firstweekday - 1] = sprintf( "%2d ", $y); } } else { for ($x = 1; $x <= $numdays; $x++, $y++) { $month_array[$x + $firstweekday - 1] = sprintf( "%2d ", $y); if ($y == 2) { $y = 13; } } } return @month_array; }; local *day_of_week_num = sub { my ($year, $month, $day) = @_; my ($a, $y, $m, $d); $a = int( (14 - $month)/12 ); $y = $year - $a; $m = $month + (12 * $a) - 2; if (is_julian($year, $month)) { $d = (5 + $day + $y + int($y/4) + int(31*$m/12)) % 7; } else { $d = ($day + $y + int($y/4) - int($y/100) + int($y/400) + int(31*$m/12)) % 7; } return $d; }; local *days_in_month = sub { my ($year, $month) = @_; my @month_days = ( 0,31,28,31,30,31,30,31,31,30,31,30,31 ); if ($month == 2 && is_leap_year($year)) { $month_days[2] = 29; } elsif ($year == 1752 && $month == 9) { $month_days[9] = 19; } return $month_days[$month]; }; local *is_julian = sub { my ($year, $month) = @_; my $bool = 0; $bool = 1 if ($year < 1752 || ($year == 1752 && $month <= 9)); return $bool; }; local *is_leap_year = sub { my $year = shift; my $bool = 0; if (is_julian($year, 1)) { $bool = 1 if ($year % 4 == 0); } else { $bool = 1 if (($year % 4 == 0 && $year % 100 != 0) || $year % 400 == 0); } return $bool; }; @out = split(/\n/, print_month(@date)); return @out; } sub input_key { # Process input a keystroke at a time. # # Usage: $self->input_key($key); my $self = shift; my $in = shift; my $conf = $self->{CONF}; my $pos = $$conf{VALUE}; my @date = split(/\//, $$conf{MONTH}); my @days = (0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); my ($y, $trigger); # Adjust for leap years, if necessary $days[2] += 1 if (($date[1] % 4 == 0 && $date[1] % 100 != 0) || $date[1] % 400 == 0); $trigger = 'd'; # Navigate according to key press if ($in eq KEY_LEFT) { $pos -= 1; } elsif ($in eq KEY_RIGHT) { $pos += 1; } elsif ($in eq KEY_UP) { $pos -= 7; } elsif ($in eq KEY_DOWN) { $pos += 7; } elsif ($in eq KEY_NPAGE) { $pos += 28; $pos += 7 if $pos <= $days[$date[0]]; } elsif ($in eq KEY_PPAGE) { $pos -= 28; $pos -= 7 if $pos > 0; } elsif ($in eq KEY_HOME || $in eq KEY_FIND) { ($pos, @date) = (localtime)[3..5]; $date[0] += 1; $date[1] += 1900; # Key press wasn't a navigation key, so reset trigger } else { $trigger = ''; } # Adjust the dates as necessary according to the cursor movement if ($pos < 1) { --$date[0]; if ($date[0] < 1) { --$date[1]; $date[0] = 12; } $pos += $days[$date[0]]; } elsif ($pos > $days[$date[0]]) { ++$date[0]; if ($date[0] > 12) { ++$date[1]; $date[0] = 1; } $pos -= $days[$date[0] > 1 ? $date[0] - 1 : 12]; } # Compare old info to the new and set trigger flags $trigger .= 'm' if $date[0] != ($$conf{MONTH} =~ /^(\d+)/)[0]; $trigger .= 'y' if $date[1] != ($$conf{MONTH} =~ /(\d+)$/)[0]; # Save the adjusted dates @$conf{qw(VALUE MONTH)} = ($pos, join('/', @date)); # Call the triggers &{$$conf{ONDAY}}($self) if (defined $$conf{ONDAY} && $trigger =~ /d/); &{$$conf{ONMONTH}}($self) if (defined $$conf{ONMONTH} && $trigger =~ /m/); &{$$conf{ONYEAR}}($self) if (defined $$conf{ONYEAR} && $trigger =~ /y/); } 1; =head1 HISTORY =over =item 1999/12/29 -- Original calendar widget in functional model =item 2001/07/05 -- First incarnation in OO architecture =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/ComboBox.pm0000644000175000017500000002256007564777120022257 0ustar srzsrz00000000000000# Curses::Widgets::ComboBox.pm -- Text Field Widgets # # (c) 2001, Arthur Corliss # # $Id: ComboBox.pm,v 1.103 2002/11/03 23:34:50 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::ComboBox - Combo-Box Widgets =head1 MODULE VERSION $Id: ComboBox.pm,v 1.103 2002/11/03 23:34:50 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::ComboBox; $cb = Curses::Widgets::ComboBox->new({ CAPTION => 'Select', CAPTIONCOL => 'yellow', COLUMNS => 10, MAXLENGTH => 255, MASK => undef, VALUE => '', INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t\n", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, X => 1, Y => 1, READONLY => 0, LISTITEMS => [qw(foo bar wop)], }); $cb->draw($mwh, 1); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =item Curses::Widgets::TextField =item Curses::Widgets::ListBox =back =head1 DESCRIPTION Curses::Widgets::ComboBox provides simplified OO access to Curses-based combo-boxes. This widget essentially acts as text field widget, but upon a KEY_DOWN or "\n", a drop-down list is displayed, and the item selected is put in the text field as the value. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::ComboBox; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; use Curses::Widgets::TextField; use Curses::Widgets::ListBox; ($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets::TextField Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $cb = Curses::Widgets::ComboBox->new({ CAPTION => 'Select', CAPTIONCOL => 'yellow', COLUMNS => 10, MAXLENGTH => 255, MASK => undef, VALUE => '', INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t\n", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, X => 1, Y => 1, READONLY => 0, LISTITEMS => [qw(foo bar wop)], }); The new method instantiates a new ComboBox object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ CAPTION undef Caption superimposed on border CAPTIONCOL undef Foreground colour for caption text COLUMNS 10 Number of columns displayed MAXLENGTH 255 Maximum string length allowed MASK undef Not yet implemented VALUE '' Current field text INPUTFUNC \&scankey Function to use to scan for keystrokes FOREGROUND undef Default foreground colour BACKGROUND undef Default background colour BORDER 1 Display a border around the field BORDERCOL undef Foreground colour for border FOCUSSWITCH "\t\n" Characters which signify end of input CURSORPOS 0 Starting position of the cursor TEXTSTART 0 Position in string to start displaying PASSWORD 0 Subsitutes '*' instead of characters READONLY 0 Prevents alteration to content LISTLINES 5 Number of lines to display at a time in the drop-down list LISTCOLUMNS[COLUMNS] Width of the drop-down list. Defaults to the same length specified for the CombBox widget LISTITEMS [] Items listed in drop-down list The B is only valid when the B is enabled. If the border is disabled, the field will be underlined, provided the terminal supports it. If B is undefined, no limit will be placed on the string length. =cut sub _conf { # Validates and initialises the new ComboBox object. # # Internal use only. my $self = shift; my %conf = ( LISTLINES => 5, FOCUSSWITCH => "\t", LISTITEMS => [], @_ ); my $err = 0; # Set the default list length to the field length if it # hasn't been defined $conf{LISTCOLUMNS} = $conf{COLUMNS} unless exists $conf{LISTLENGTH}; # Make sure no errors are returned by the parent method $err = 1 unless $self->SUPER::_conf(%conf); # Get updated conf hash %conf = (); %conf = %{$self->{CONF}}; # Create a list box object for the popup if no errors were encountered $self->{LISTBOX} = Curses::Widgets::ListBox->new({ X => 0, Y => 0, LISTITEMS => $conf{LISTITEMS}, INPUTFUNC => $conf{INPUTFUNC}, BORDERCOL => $conf{BORDERCOL}, FOREGROUND => $conf{FOREGROUND}, BACKGROUND => $conf{BACKGROUND}, LINES => $conf{LISTLINES}, COLUMNS => $conf{LISTCOLUMNS}, FOCUSSWITCH => "\n\e", BORDER => $conf{BORDER}, }) unless $err; return $err == 0 ? 1 : 0; } =head2 draw (inherited from Curses::Widgets::TextField) $cb->draw($mwh, 1); The draw method renders the text field in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the field's text cursor to be rendered as well. =cut sub _geometry { my $self = shift; my $conf = $self->{CONF}; my @rv = @$conf{qw(LINES COLUMNS Y X)}; if ($$conf{BORDER}) { $rv[0] += 2; $rv[1] += 4; } else { $rv[1]++; } return @rv; } sub _border { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($y, $x); # Get maxyx $dwh->getmaxyx($y, $x); # Set the colours $dwh->attrset(COLOR_PAIR( select_colour(@$conf{qw(BORDERCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{BORDERCOL} eq 'yellow'; # Border rendering if ($$conf{BORDER}) { # Draw the main box $self->SUPER::_border($dwh); # Draw the tee intersections and arrow $dwh->addch($y - 2, $x - 2, ACS_DARROW); $dwh->addch(0, $x - 3 , ACS_TTEE); $dwh->addch($y - 2, $x - 3, ACS_VLINE); $dwh->addch($y - 1, $x - 3, ACS_BTEE); # No border still requires the down-arrow } else { $dwh->addch(0, $x - 1, ACS_DARROW); } # Restore the default settings $self->_restore($dwh); } sub draw { my $self = shift; my $mwh = shift; my $active = shift; my ($by, $bx); # Get and store the window's beginning y & x $mwh->getbegyx($by, $bx); $self->{BEGYX} = [$by, $bx]; # Call the parent draw return $self->SUPER::draw($mwh, $active); } =head2 popup $combo->popup; This method causes the drop down list to be displayed. Since, theoretically, this list should never be seen unless it's being actively used, we will always assume that we need to draw a cursor on the list as well. =cut sub popup { my $self = shift; my $conf = $self->{CONF}; my ($x, $y, $border) = @$conf{qw(X Y BORDER)}; my ($by, $bx) = @{$self->{BEGYX}}; my $lb = $self->{LISTBOX}; my ($pwh, $items, $cp, $in, $key); # Calculate the border column/lines $border *= 2; if ($border) { $y--; } else { $y++; } # Create the popup window unless ($pwh = newwin($$conf{LISTLINES} + $border, $$conf{LISTCOLUMNS} + $border, $y + $border + $by, $x + $border + $bx)) { carp ref($self), ": Popup creation failed, possible geometry problems"; return; } $pwh->keypad(1); # Render the list box $key = $lb->execute($pwh); # Release the window $pwh->delwin; # Place the selected listbox value into the textfield if user # pressed enter if ($key eq "\n") { ($cp, $items) = $lb->getField(qw(CURSORPOS LISTITEMS)); $$conf{VALUE} = $$items[$cp] if (defined $cp && scalar @$items); } } sub input_key { # Process input a keystroke at a time. # # Internal use only. my $self = shift; my $in = shift; my $conf = $self->{CONF}; # Handle only special keys that will pull down the list if ($in eq "\n") { } elsif ($in eq KEY_DOWN) { $self->popup; # Hand everything else to the text widget } else { $self->SUPER::input_key($in); } } 1; =head1 HISTORY =over =item 2001/12/09 -- First version of the combo box =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/Label.pm0000644000175000017500000001145207564777120021564 0ustar srzsrz00000000000000# Curses::Widgets::Label.pm -- Label Widgets # # (c) 2001, Arthur Corliss # # $Id: Label.pm,v 1.102 2002/11/03 23:36:21 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::Label - Label Widgets =head1 MODULE VERSION $Id: Label.pm,v 1.102 2002/11/03 23:36:21 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::Label; $lbl = Curses::Widgets::Label->new({ COLUMNS => 10, LINES => 1, VALUE => 'Name:', FOREGROUND => undef, BACKGROUND => 'black', X => 1, Y => 1, ALIGNMENT => 'R', }); $tf->draw($mwh); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =back =head1 DESCRIPTION Curses::Widgets::Label provides simplified OO access to Curses-based single or multi-line labels. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::Label; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; ($VERSION) = (q$Revision: 1.102 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $lbl = Curses::Widgets::Label->new({ COLUMNS => 10, LINES => 1, VALUE => 'Name:', FOREGROUND => undef, BACKGROUND => 'black', X => 1, Y => 1, ALIGNMENT => 'R', }); The new method instantiates a new Label object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ COLUMNS 10 Number of columns displayed LINES 1 Number of lines displayed VALUE '' Label text FOREGROUND undef Default foreground colour BACKGROUND undef Default background colour ALIGNMENT L 'R'ight, 'L'eft, or 'C'entered If the label is a multi-line label it will filter the current VALUE through the Curses::Widgets::textwrap function to break it along whitespace and newlines. =cut sub _conf { # Validates and initialises the new Label object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( COLUMNS => 10, LINES => 1, VALUE => '', ALIGNMENT => 'L', BORDER => 0, @_ ); my @required = qw(X Y); my $err = 0; # Check for required arguments foreach (@required) { $err = 1 unless exists $conf{$_} }; $conf{ALIGNMENT} = uc($conf{ALIGNMENT}); # Make sure no errors are returned by the parent method $err = 1 unless $self->SUPER::_conf(%conf); return $err == 0 ? 1 : 0; } =head2 draw $tf->draw($mwh); The draw method renders the text field in its current state. This requires a valid handle to a curses window in which it will render itself. =cut sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($lines, $cols, $value) = @$conf{qw(LINES COLUMNS VALUE)}; my (@lines, $offset); # Get the lines @lines = textwrap($value, $cols); # Write the widget value foreach (0..$lines) { next unless defined $lines[$_]; $offset = $$conf{ALIGNMENT} eq 'C' ? int(($$conf{COLUMNS} - length($lines[$_])) / 2) : ($$conf{ALIGNMENT} eq 'R' ? $$conf{COLUMNS} - length($lines[$_]) : 0); $offset = 0 if $offset < 0; $dwh->addstr(0 + $_, 0 + $offset, $lines[$_]) if $_ <= $#lines; } } # The following are overridden to make sure no one tries anything fancy with # this widget. ;-) sub input_key { return; } sub execute { return; } 1; =head1 HISTORY =over =item 2002/10/18 -- First implementation =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/ListBox/0000755000175000017500000000000010021050434021536 5ustar srzsrz00000000000000libcurses-widgets-perl-1.997.orig/Widgets/ListBox/MultiColumn.pm0000644000175000017500000002201507564777120024376 0ustar srzsrz00000000000000# Curses::Widgets::ListBox::MultiColumn.pm -- Multi-Column List Box Widgets # # (c) 2001, Arthur Corliss # # $Id: MultiColumn.pm,v 0.1 2002/11/14 01:28:49 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::ListBox::MultiColumn - Multi-Column List Box Widgets =head1 MODULE VERSION $Id: MultiColumn.pm,v 0.1 2002/11/14 01:28:49 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::ListBox::MultiColumn; $lb = Curses::Widgets::ListBox::MultiColumn->new({ COLUMNS => [0, 5, 10, 3, 3], LISTITEMS => [@list], }); $lb->draw($mwh, 1); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =item Curses::Widgets::ListBox =back =head1 DESCRIPTION Curses::Widgets::ListBox::MultiColumn is an extension of the standard Curses::Widgets::ListBox that allows a list of columns, with each column a specified width. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::ListBox::MultiColumn; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; use Curses::Widgets::ListBox; ($VERSION) = (q$Revision: 0.1 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets::ListBox); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $tm = Curses::Widgets::ListBox->new({ COLUMNS => [0, 5, 10, 3, 3], LISTITEMS => [@list], HEADERS => [@headers], HEADERCOLFG => 'white', HEADERCOLBG => 'green', BIGHEADER => 1, }); All of the same key values apply here as they do for the parent class Curses::Widgets::ListBox. In addition, the following new keys are defined: Key Default Description ============================================================ COLUMNS [] Column widths LISTITEMS [] List of list values HEADERS [] Column header labels HEADERFGCOL undef Header foreground colour HEADERBGCOL undef Header background colour BIGHEADER 0 Use more graphics for the header KEYINDX 0 Index of key column If headers are defined but one or both of the header colours are not, then they will default to the widget fore and background. B: Headers take up more lines in addition to the border (one line for the normal, small header, two lines for the larger). You need to take that into account when setting the geometry. If no labels are passed in the HEADERS array, no space will be used for the headers. The B value is currently only used to match keystrokes against for quick navigation. =cut sub _conf { # Validates and initialises the new ListBox object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( COLWIDTHS => [10], KEYINDEX => 0, HEADERS => [], BIGHEADER => 0, KEYINDX => 0, @_ ); my $err = 0; my @required = qw(COLWIDTHS); # Check for required fields foreach (@required) { $err = 1 unless exists $conf{$_} }; $err = 1 unless @{$conf{COLWIDTHS}}; # Lowercase extra colours foreach (qw(HEADERFGCOL HEADERBGCOL)) { $conf{$_} = lc($conf{$_}) if exists $conf{$_} }; # Make sure no errors are returned by the parent method $err = 1 unless $self->SUPER::_conf(%conf); return $err == 0 ? 1 : 0; } =head2 draw $lb->draw($mwh, 1); The draw method renders the list box in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the field's text cursor to be rendered as well. =cut sub _geometry { my $self = shift; my $conf = $self->{CONF}; my @rv; @rv = $self->SUPER::_geometry; if (@{$$conf{HEADERS}}) { $rv[0]++; $rv[0]++ if $$conf{BIGHEADER}; } return @rv; } sub _cgeometry { my $self = shift; my $conf = $self->{CONF}; my @rv; @rv = $self->SUPER::_cgeometry; if (@{$$conf{HEADERS}}) { $rv[2]++; $rv[2]++ if $$conf{BIGHEADER}; } return @rv; } sub _border { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my (@colours, $header, @headers, $i, $h); my ($y, $x); # Render the border $self->SUPER::_border($dwh); # Draw the headers if any were defined if (@{$$conf{HEADERS}}) { # Construct the header $i = -1; foreach (@{$$conf{COLWIDTHS}}) { ++$i; next unless $_; $h = $$conf{HEADERS}[$i] || ''; $header .= substr($h, 0, $_); $header .= ' ' x ($_ - length($h)) if length($h) < $_; $header .= ' '; } chop $header; # Print the header $i = $$conf{BORDER} ? 1 : 0; $dwh->addstr($i, $i, substr($header, 0, $$conf{COLUMNS})); # Set the colours push(@colours, exists $$conf{HEADERFGCOL} ? $$conf{HEADERFGCOL} : $$conf{FOREGROUND}); push(@colours, exists $$conf{HEADERBGCOL} ? $$conf{HEADERBGCOL} : $$conf{BACKGROUND}); $dwh->chgat($i, $i, $$conf{COLUMNS}, $colours[0] eq 'yellow' ? A_BOLD : 0, select_colour(@colours), 0); # Draw the big header graphics if ($$conf{BIGHEADER}) { # Use the border colours $dwh->attrset(COLOR_PAIR( select_colour(@$conf{qw(BORDERCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{BORDERCOL} eq 'yellow'; # Draw the lower line $dwh->getmaxyx($y, $x); for (0..($x - 1)) { $dwh->addch($i + 1, $_, ACS_HLINE) }; # Draw the vertical lines and tees $h = 0; foreach (@{$$conf{COLWIDTHS}}) { $h += $_ + $i; last if $h > $$conf{COLUMNS}; $dwh->addch(0, $h, ACS_TTEE) if $i == 1; $dwh->addch($i, $h, ACS_VLINE); $dwh->addch($i + 1, $h, ACS_BTEE); } if ($$conf{BORDER}) { $dwh->addch($i + 1, 0, ACS_LTEE); $dwh->addch($i + 1, $x - 1, ACS_RTEE); } } $self->_restore($dwh); } } sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($pos, $top, $border, $cols, $lines, $sel) = @$conf{qw(CURSORPOS TOPELEMENT BORDER COLUMNS LINES VALUE)}; my @items = @{$$conf{LISTITEMS}}; my (@colours, $h, $i, $j, $item); # Turn on underlining (terminal-dependent) if no border is used $dwh->attron(A_UNDERLINE) unless $border; # Display the items on the list if (scalar @items) { # Display the items for $i ($top..$#items) { # Construct the header $j = -1; $item = ''; foreach (@{$$conf{COLWIDTHS}}) { ++$j; next unless $_; $h = $items[$i][$j] || ''; $item .= substr($h, 0, $_); $item .= ' ' x ($_ - length($h)) if length($h) < $_; $item .= ' '; } chop $item; @colours = @$conf{qw(FOREGROUND BACKGROUND)}; if (defined $sel && grep /^$i$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) { # Set the colour for selected items if (exists $$conf{SELECTEDCOL}) { $colours[0] = $$conf{SELECTEDCOL}; $dwh->attrset(COLOR_PAIR(select_colour( @$conf{qw(SELECTEDCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{SELECTEDCOL} eq 'yellow'; # Bold it if no selection colour was defined } else { $dwh->attron(A_BOLD); } } # Print the item $dwh->addstr($i - $top, 0, substr($item, 0, $cols)); # Underline the line if there's no border $dwh->chgat($i - $top, 0, $cols, A_UNDERLINE, select_colour(@colours), 0) unless $border; # Restore the default settings $self->_restore($dwh); } } } sub match_key { my $self = shift; my $in = shift; my $conf = $self->{CONF}; my @items = @{$$conf{LISTITEMS}}; my ($pos, $indx) = @$conf{qw(CURSORPOS KEYINDX)}; my $np; $np = $pos + 1; while ($np <= $#items && $items[$np][$indx] !~ /^\Q$in\E/i) { $np++ }; $pos = $np if $np <= $#items and $items[$np][$indx] =~ /^\Q$in\E/i; return $pos; } 1; =head1 HISTORY =over =item 1999/12/29 -- Original list box widget in functional model =item 2001/07/05 -- First incarnation in OO architecture =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/ListBox.pm0000644000175000017500000002503607564777120022134 0ustar srzsrz00000000000000# Curses::Widgets::ListBox.pm -- List Box Widgets # # (c) 2001, Arthur Corliss # # $Id: ListBox.pm,v 1.104 2002/11/14 01:20:28 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::ListBox - List Box Widgets =head1 MODULE VERSION $Id: ListBox.pm,v 1.104 2002/11/14 01:20:28 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::ListBox; $lb = Curses::Widgets::ListBox->new({ CAPTION => 'List', CAPTIONCOL => 'yellow', COLUMNS => 10, LINES => 3, VALUE => 0, INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', SELECTEDCOL => 'green', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t", X => 1, Y => 1, TOPELEMENT => 0, LISTITEMS => [@list], }); $lb->draw($mwh, 1); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =back =head1 DESCRIPTION Curses::Widgets::ListBox provides simplified OO access to Curses-based single/multi-select list boxes. Each object maintains its own state information. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::ListBox; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; ($VERSION) = (q$Revision: 1.104 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $tm = Curses::Widgets::ListBox->new({ CAPTION => 'List', CAPTIONCOL => 'yellow', COLUMNS => 10, LINES => 3, VALUE => 0, INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', SELECTEDCOL => 'green', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t", X => 1, Y => 1, TOPELEMENT => 0, LISTITEMS => [@list], }); The new method instantiates a new ListBox object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ CAPTION undef Caption superimposed on border CAPTIONCOL undef Foreground colour for caption text COLUMNS 10 Number of columns displayed LINES 3 Number of lines in the window INPUTFUNC \&scankey Function to use to scan for keystrokes FOREGROUND undef Default foreground colour BACKGROUND undef Default background colour SELECTEDCOL undef Default colour of selected items BORDER 1 Display a border around the field BORDERCOL undef Foreground colour for border FOCUSSWITCH "\t" Characters which signify end of input TOPELEMENT 0 Index of element displayed on line 1 LISTITEMS [] List of list items MULTISEL 0 Whether or not multiple items can be selected TOGGLE "\n\s" What input toggles selection of the current item VALUE 0 or [] Index(es) of selected items CURSORPOS 0 Index of the item the cursor is currently on The B is only valid when the B is enabled. If the border is disabled, the field will be underlined, provided the terminal supports it. The value of B should be an array reference when in multiple selection mode. Otherwise it should either undef or an integer. =cut sub _conf { # Validates and initialises the new ListBox object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( COLUMNS => 10, LINES => 3, VALUE => undef, INPUTFUNC => \&scankey, BORDER => 1, FOCUSSWITCH => "\t", TOPELEMENT => 0, LISTITEMS => [], MULTISEL => 0, VALUE => undef, CURSORPOS => 0, TOGGLE => "\n ", @_ ); my @required = qw(X Y); my $err = 0; # Check for required arguments foreach (@required) { $err = 1 unless exists $conf{$_} }; $conf{SELECTEDCOL} = lc($conf{SELECTEDCOL}) if exists $conf{SELECTEDCOL}; # Make sure no errors are returned by the parent method $err = 1 unless $self->SUPER::_conf(%conf); # Update VALUE depending on selection mode $conf{VALUE} = [] if $conf{MULTISEL} and not exists $conf{VALUE}; return $err == 0 ? 1 : 0; } =head2 draw $lb->draw($mwh, 1); The draw method renders the list box in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the field's text cursor to be rendered as well. =cut sub _border { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($top, $pos, $lines, $cols, $items) = @$conf{qw(TOPELEMENT CURSORPOS LINES COLUMNS LISTITEMS)}; my ($y, $x); # Render the box $self->SUPER::_border($dwh); # Adjust the cursor position if it's out of whack $pos = $#{$items} if $pos > $#{$items}; while ($pos - $top > $lines - 1) { $top++ }; while ($top > $pos) { --$top }; # Render up/down arrows as needed $dwh->getmaxyx($y, $x); $dwh->addch(0, $x - 2, ACS_UARROW) if $top > 0; $dwh->addch($y - 1, $x - 2, ACS_DARROW) if $top + $lines < @$items ; # Restore the default settings $self->_restore($dwh); # Save any massaged values @$conf{qw(TOPELEMENT CURSORPOS)} = ($top, $pos); } sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($pos, $top, $border, $cols, $lines, $sel) = @$conf{qw(CURSORPOS TOPELEMENT BORDER COLUMNS LINES VALUE)}; my @items = @{$$conf{LISTITEMS}}; my (@colours, $i); # Turn on underlining (terminal-dependent) if no border is used $dwh->attron(A_UNDERLINE) unless $border; # Display the items on the list if (scalar @items) { # Display the items for $i ($top..$#items) { @colours = @$conf{qw(FOREGROUND BACKGROUND)}; if (defined $sel && grep /^$i$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) { # Set the colour for selected items if (exists $$conf{SELECTEDCOL}) { $colours[0] = $$conf{SELECTEDCOL}; $dwh->attrset(COLOR_PAIR(select_colour( @$conf{qw(SELECTEDCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{SELECTEDCOL} eq 'yellow'; # Bold it if no selection colour was defined } else { $dwh->attron(A_BOLD); } } # Print the item $dwh->addstr($i - $top, 0, substr($items[$i], 0, $cols)); # Underline the line if there's no border $dwh->chgat($i - $top, 0, $cols, A_UNDERLINE, select_colour(@colours), 0) unless $border; # Restore the default settings $self->_restore($dwh); } } } sub _cursor { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($pos, $top, $cols, $sel) = @$conf{qw(CURSORPOS TOPELEMENT COLUMNS VALUE)}; my $fg; # Determine the foreground colour if (defined $sel && exists $$conf{SELECTEDCOL} && grep /^$pos$/, (ref($sel) eq 'ARRAY' ? @$sel : $sel)) { $fg = $$conf{SELECTEDCOL}; } else { $fg = $$conf{FOREGROUND}; } # Display the cursor $dwh->chgat($pos - $top, 0, $cols, A_STANDOUT, select_colour( $fg, $$conf{BACKGROUND}), 0); # Restore the default settings $self->_restore($dwh); } sub input_key { # Process input a keystroke at a time. # # Usage: $self->input_key($key); my $self = shift; my $in = shift; my $conf = $self->{CONF}; my $sel = $$conf{VALUE}; my @items = @{$$conf{LISTITEMS}}; my $pos = $$conf{CURSORPOS}; my $re = $$conf{TOGGLE}; my $np; # Process special keys if ($in eq KEY_UP) { if ($pos > 0) { --$pos; } else { beep; } } elsif ($in eq KEY_DOWN) { if ($pos < $#items) { ++$pos; } else { beep; } } elsif ($in eq KEY_HOME || $in eq KEY_END || $in eq KEY_PPAGE || $in eq KEY_NPAGE) { if (scalar @items) { if ($in eq KEY_HOME) { beep if $pos == 0; $pos = 0; } elsif ($in eq KEY_END) { beep if $pos == $#items; $pos = $#items; } elsif ($in eq KEY_PPAGE) { beep if $pos == 0; $pos -= $$conf{LINES}; $pos = 0 if $pos < 0; } elsif ($in eq KEY_NPAGE) { beep if $pos == $#items; $pos += $$conf{LINES}; $pos = $#items if $pos > $#items; } } else { beep; } # Process normal key strokes } else { # Exit out if there's no list to apply strokes to return unless scalar @items; if ($in =~ /^[$re]$/) { if ($$conf{MULTISEL}) { if (grep /^$pos$/, @$sel) { @$sel = grep !/^$pos$/, @$sel; } else { push(@$sel, $pos); } } else { $sel = $pos; } } elsif ($in =~ /^[[:print:]]$/ && $pos < $#items) { $pos = $self->match_key($in); } else { beep; } } # Save the changes @$conf{qw(VALUE CURSORPOS)} = ($sel, $pos); } sub match_key { my $self = shift; my $in = shift; my $conf = $self->{CONF}; my @items = @{$$conf{LISTITEMS}}; my $pos = $$conf{CURSORPOS}; my $np; $np = $pos + 1; while ($np <= $#items && $items[$np] !~ /^\Q$in\E/i) { $np++ }; $pos = $np if $np <= $#items and $items[$np] =~ /^\Q$in\E/i; return $pos; } 1; =head1 HISTORY =over =item 1999/12/29 -- Original list box widget in functional model =item 2001/07/05 -- First incarnation in OO architecture =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/Menu.pm0000644000175000017500000002535707564777120021462 0ustar srzsrz00000000000000# Curses::Widgets::Menu.pm -- Menu Widgets # # (c) 2001, Arthur Corliss # # $Id: Menu.pm,v 1.103 2002/11/14 01:26:34 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::Menu - Menu Widgets =head1 MODULE VERSION $Id: Menu.pm,v 1.103 2002/11/14 01:26:34 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::Menu; $menu = Curses::Widgets::Menu->new({ COLUMNS => 10, INPUTFUNC => \&scankey, FOREGROUND => undef, BACKGROUND => 'black', FOCUSSWITCH => "\t", X => 1, Y => 1, MENUS => { MENUORDER => [qw(File)], File => { ITEMORDER => [qw(Save Quit)], Save => \&Save, Quit => \&Quit, }, CURSORPOS => 'File', BORDER => 1, }); $menu->draw($mwh, 1); $menu->execute; See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =item Curses::Widgets::ListBox =back =head1 DESCRIPTION Curses::Widgets::Menu provides simplified OO access to menus. Each item in a menu can be tied to a subroutine reference which is called when selected. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::Menu; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; use Curses::Widgets::ListBox; ($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $menu = Curses::Widgets::Menu->new({ INPUTFUNC => \&scankey, FOREGROUND => undef, BACKGROUND => 'black', FOCUSSWITCH => "\t", MENUS => { MENUORDER => [qw(File)], File => { ITEMORDER => [qw(Save Quit)], Save => \&Save, Quit => \&Quit, }, CURSORPOS => 'File', BORDER => 1, }); The new method instantiates a new Menu object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ INPUTFUNC \&scankey Function to use to scan for keystrokes FOREGROUND undef Default foreground colour BACKGROUND 'black' Default background colour FOCUSSWITCH "\t" Characters which signify end of input MENUS {} Menu structure CURSORPOS '' Current position of the cursor BORDER 0 Avoid window borders The B option is a hash of hashes, with each hash a separate menu, and the constituent hashes being a Entry/Function pairs. Each hash requires a special key/value pair that determines the order of the items when displayed. Each item is separated by two spaces. =cut sub _conf { # Validates and initialises the new Menu object. # # Internal use only. my $self = shift; my %conf = ( INPUTFUNC => \&scankey, FOREGROUND => undef, BACKGROUND => 'black', FOCUSSWITCH => "\t", MENUS => {MENUORDER => []}, BORDER => 0, EXIT => 0, CURSORPOS => '', @_ ); my $err = 0; # Set the default CURSORPOS if undefined $conf{CURSORPOS} = $conf{MENUS}{MENUORDER}[0] unless defined $conf{CURSORPOS}; # Make sure no errors are returned by the parent method $err = 1 unless $self->SUPER::_conf(%conf); # Get the updated conf hash %conf = (); %conf = %{$self->{CONF}}; # Create a listbox as our popup menu $self->{LISTBOX} = Curses::Widgets::ListBox->new({ X => 0, Y => 0, LISTITEMS => [], FOREGROUND => $conf{FOREGROUND}, BACKGROUND => $conf{BACKGROUND}, LINES => 3, COLUMNS => 10, FOCUSSWITCH => "\n\e", INPUTFUNC => $conf{INPUTFUNC}, }) unless $err; return $err == 0 ? 1 : 0; } =head2 draw $menu->draw($mwh, 1); The draw method renders the menu in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the selection cursor to be rendered as well. =cut sub draw { my $self = shift; my $mwh = shift; my $active = shift; my $conf = $self->{CONF}; my ($y, $x); # Get the parent window's (max|beg)yx and save the info $mwh->getmaxyx($y, $x); $$conf{COLUMNS} = $x; $mwh->getbegyx($y, $x); $self->{BEGYX} = [$y, $x]; # Call the parent's draw method return $self->SUPER::draw($mwh, $active); } sub _geometry { my $self = shift; my $conf = $self->{CONF}; my @rv = (1, $$conf{COLUMNS}, 0, 0); if ($$conf{BORDER}) { $rv[1] -= 2; @rv[2,3] = (1, 1); } return @rv; } sub _cgeometry { my $self = shift; my $conf = $self->{CONF}; my @rv = (1, $$conf{COLUMNS}, 0, 0); $rv[1] -= 2 if $$conf{BORDER}; return @rv; } sub _border { # Make sure no one tries to call this on a menu } sub _caption { # Make sure no one tries to call this on a menu } sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my $menu = $$conf{MENUS}; my $label; # Print the labels $label = join(' ', @{$$menu{MENUORDER}}); carp ref($self), ": Window not wide enough to display all menus!" if length($label) > $$conf{COLUMNS} - 2 * $$conf{BORDER}; $dwh->addstr(0, 0, $label); } sub _cursor { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my $menu = $$conf{MENUS}; my $pos = $$conf{CURSORPOS}; my ($x, $label); # Get the x coordinate of the cursor and display the cursor $label = join(' ', @{$$menu{MENUORDER}}); if ($label =~ /^(.*\b)\Q$pos\E\b/) { $x = length($1); $dwh->chgat(0, $x, length($pos), A_STANDOUT, select_colour( @$conf{qw(FOREGROUND BACKGROUND)}), 0); } $self->_restore($dwh); } =head2 popup $menu->popup; This method causes the menu to be displayed. Since, theoretically, the menu should never be seen unless it's being actively used, we will always assume that we need to draw a cursor on the list as well. =cut sub popup { my $self = shift; my $conf = $self->{CONF}; my ($x, $y, $border) = (@$conf{qw(X Y)}, 1); my $lb = $self->{LISTBOX}; my ($pwh, $items, $cp, $in, $rv, $l); # Calculate the border column/lines $border *= 2; # Create the popup window unless ($pwh = newwin($lb->getField('LINES') + $border, $lb->getField('COLUMNS') + $border, $y, $x)) { carp ref($self), ": Popup creation failed, possible geometry problems"; return; } $pwh->keypad(1); # Render the list box $rv = $lb->execute($pwh); # Release the window $pwh->delwin; # Exit now if $rv is an escape return undef if $rv =~ /\e/; # Return the menu selection ($cp, $items) = $lb->getField(qw(CURSORPOS LISTITEMS)); return $$items[$cp] if (defined $cp && scalar @$items); } sub input_key { # Process input a keystroke at a time. # # Internal use only. my $self = shift; my $in = shift; my $conf = $self->{CONF}; my $lb = $self->{LISTBOX}; my ($menus, $pos) = @$conf{qw(MENUS CURSORPOS)}; my ($width, $height, $x, $y, $i, $j, $item, $rv, $sub, $l); return unless @{$$menus{MENUORDER}}; # Get the current menu index $i = 0; while ($i < @{$$menus{MENUORDER}} && $$menus{MENUORDER}[$i] ne $pos) { $i++ }; $item = $$menus{MENUORDER}[$i]; # Process special keys if ($in eq KEY_LEFT) { --$i; $i = $#{$$menus{MENUORDER}} if $i < 0; } elsif ($in eq KEY_RIGHT) { ++$i; $i = 0 if $i > $#{$$menus{MENUORDER}}; # Display the Menu } elsif ($in eq KEY_DOWN || $in eq "\n") { # Calculate and set popup geometry $x = 0; for (0..$i) { $x += (length($$menus{MENUORDER}[$i]) + 2) if $_ != $i; } $x += 1 if $$conf{BORDER}; $x += $self->{BEGYX}->[1]; $y = $$conf{BORDER} ? 2 : 1; $y += $self->{BEGYX}->[0]; @$conf{qw(Y X)} = ($y, $x); $l = 0; foreach (@{$$menus{$item}{ITEMORDER}}) { $l = length($_) if $l < length($_) }; $lb->setField( LISTITEMS => [ @{$$menus{$item}{ITEMORDER}} ], LINES => scalar @{$$menus{$item}{ITEMORDER}}, COLUMNS => $l, CURSORPOS => 0, ); # Display the popup $rv = $self->popup; if (defined $rv) { $$conf{EXIT} = 1; # Execute the reference { no strict 'refs'; $sub = $$menus{$item}{$rv}; if (defined $sub) { &$sub(); } else { carp ref($self), ": undefined subroutine ($rv) call attempted"; } } } # Process normal key strokes } else { beep(); } # Save the changes $pos = $$menus{MENUORDER}[$i]; $$conf{CURSORPOS} = $pos; } =head2 execute $menu->execute; This method acts like the standard Curses::Widgets method of the same name, with the exception being that selection of any menu item will also cause it to exit (having already called the associated item subroutine). =cut sub execute { my $self = shift; my $mwh = shift; my $conf = $self->{CONF}; my $menus = $$conf{MENUS}; my $func = $$conf{'INPUTFUNC'} || \&scankey; my $regex = $$conf{'FOCUSSWITCH'}; my $key; # Don't execute unless we have menus to interact with return unless @{$$menus{MENUORDER}}; # Set the initial focused menu to the first in the list $$conf{CURSORPOS} = $$menus{MENUORDER}[0]; $$conf{EXIT} = 0; $self->draw($mwh, 1); # Enter the scan loop while (1) { $key = &$func($mwh); if (defined $key) { if (defined $regex) { return $key if ($key =~ /^[$regex]/ || ($regex =~ /\t/ && $key eq KEY_STAB)); } $self->input_key($key); } return $key if $$conf{EXIT}; $self->draw($mwh, 1); } } 1; =head1 HISTORY =over =item 2002/10/17 -- First implementation =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/ProgressBar.pm0000644000175000017500000001455507564777120023005 0ustar srzsrz00000000000000# Curses::Widgets::ProgressBar.pm -- Progress Bar Widgets # # (c) 2001, Arthur Corliss # # $Id: ProgressBar.pm,v 1.103 2002/11/03 23:40:04 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::ProgressBar - Progress Bar Widgets =head1 MODULE VERSION $Id: ProgressBar.pm,v 1.103 2002/11/03 23:40:04 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::ProgressBar; $progress = Curses::Widgets::ProgessBar->({ CAPTION => 'Progress', CAPTIONCOL => 'yellow', LENGTH => 10, VALUE => 0, FOREGROUND => undef, BACKGROUND => 'black', BORDER => 1, BORDERCOL => undef, HORIZONTAL => 1, X => 1, Y => 1, MIN => 0, MAX => 100, }); $progress->draw($mwh); $progress->input(5); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =back =head1 DESCRIPTION Curses::Widgets::ProgressBar provides simplified OO access to Curses-based progress bar. Each object maintains it's own state information. Note that this widget is designed for rendering, not interactive input. The application should update the the value of the bar by either calling the B method, which will add the passed value to the widget's current value, or by setting the value directly via the B method. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::ProgressBar; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; ($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $progress = Curses::Widgets::ProgressBar->({ CAPTION => 'Progress', CAPTIONCOL => 'yellow', LENGTH => 10, VALUE => 0, FOREGROUND => undef, BACKGROUND => 'black', BORDER => 1, BORDERCOL => undef, HORIZONTAL => 1, X => 1, Y => 1, MIN => 0, MAX => 100, }); The new method instantiates a new Progress Bar object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ CAPTION undef Caption superimposed on border CAPTIONCOL undef Foreground colour for caption text LENGTH 10 Number of columns for the bar VALUE 0 Current value FOREGROUND undef Default foreground colour BACKGROUND undef Default blackground colour BORDER 1 Display border around the set BORDERCOL undef Foreground colour for border HORIZONTAL 1 Horizontal orientation for bar MIN 0 Low value for bar (0%) MAX 100 High vlaue for bar (100%) Setting the value will change the length of the bar, based on the bounds set with B and B. The B is only rendered on the border of a horizontal progress bar. =cut sub _conf { # Validates and initialises the new TextField object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( CAPTION => undef, LENGTH => 10, VALUE => 0, BORDER => 1, HORIZONTAL => 1, MIN => 0, MAX => 100, @_ ); my @required = qw(X Y); my $err = 0; $conf{COLUMNS} = $conf{HORIZONTAL} ? $conf{LENGTH} : 0; # Check for required arguments foreach (@required) { $err = 1 unless exists $conf{$_} }; $conf{VALUE} = $conf{MIN} if $conf{VALUE} < $conf{MIN}; $err = 1 unless $self->SUPER::_conf(%conf); return $err == 0 ? 1 : 0; } =head2 draw $progress->draw($mwh); The draw method renders the progress bar in its current state. This requires a valid handle to a curses window in which it will render itself. =cut sub _geometry { my $self = shift; my $conf = $self->{CONF}; my @rv; @rv = @$conf{qw(HORIZONTAL LENGTH Y X)}; @rv[0,1] = @rv[1,0] unless ($rv[0]); if ($$conf{BORDER}) { $rv[0] += 2; $rv[1] += 2; } return @rv; } sub _cgeometry { my $self = shift; my $conf = $self->{CONF}; my @rv; @rv = @$conf{qw(HORIZONTAL LENGTH Y X)}; @rv[0,1] = @rv[1,0] unless ($rv[0]); @rv[2,3] = (1, 1) if $$conf{BORDER}; return @rv; } sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($hz, $value, $length, $min, $max) = @$conf{qw(HORIZONTAL VALUE LENGTH MIN MAX)}; my ($i, $j, $k, $l); # Draw the bar $i = ($max - $min) / $length; $j = $min; $l = $hz ? 0 : $length - 1; $k = 0; while ($j < $value) { $dwh->addch($k, $l, ACS_CKBOARD); $hz ? ++$l : --$k; $j += $i; } $dwh->attroff(A_BOLD); } sub input_key { # Since this widget doesn't handle interactive input, # this routine does nothing. } sub execute { # Since this widget doesn't handle interactive input, # this routine does nothing. } =head2 input $progress->input(5); The argument is added to the progress bar's current value. =cut sub input { my $self = shift; my $value = shift || 0; my $conf = $self->{CONF}; $$conf{VALUE} += $value; } 1; =head1 HISTORY =over =item 2001/07/05 -- First implementation =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/TextField.pm0000644000175000017500000002156307564777120022441 0ustar srzsrz00000000000000# Curses::Widgets::TextField.pm -- Text Field Widgets # # (c) 2001, Arthur Corliss # # $Id: TextField.pm,v 1.103 2002/11/04 00:35:44 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::TextField - Text Field Widgets =head1 MODULE VERSION $Id: TextField.pm,v 1.103 2002/11/04 00:35:44 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::TextField; $tf = Curses::Widgets::TextField->new({ CAPTION => 'Name', CAPTIONCOL => 'yellow', COLUMNS => 10, MAXLENGTH => 255, MASK => undef, VALUE => '', INPUTFUNC => \&scankey, FOREGROUND => undef, BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t\n", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, X => 1, Y => 1, READONLY => 0, }); $tf->draw($mwh, 1); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =back =head1 DESCRIPTION Curses::Widgets::TextField provides simplified OO access to Curses-based single line text fields. Each object maintains its own state information. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::TextField; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; ($VERSION) = (q$Revision: 1.103 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $tf = Curses::Widgets::TextField->new({ CAPTION => 'Name', CAPTIONCOL => 'yellow', COLUMNS => 10, MAXLENGTH => 255, MASK => undef, VALUE => '', INPUTFUNC => \&scankey, FOREGROUND => undef, BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t\n", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, X => 1, Y => 1, READONLY => 0, }); The new method instantiates a new TextField object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ CAPTION undef Caption superimposed on border CAPTIONCOL undef Foreground colour for caption text COLUMNS 10 Number of columns displayed MAXLENGTH 255 Maximum string length allowed MASK undef Not yet implemented VALUE '' Current field text INPUTFUNC \&scankey Function to use to scan for keystrokes FOREGROUND undef Default foreground colour BACKGROUND undef Default background colour BORDER 1 Display a border around the field BORDERCOL undef Foreground colour for border FOCUSSWITCH "\t\n" Characters which signify end of input CURSORPOS 0 Starting position of the cursor TEXTSTART 0 Position in string to start displaying PASSWORD 0 Subsitutes '*' instead of characters READONLY 0 Prevents alteration to content The B is only valid when the B is enabled. If the border is disabled, the field will be underlined, provided the terminal supports it. If B is undefined, no limit will be placed on the string length. If B is true, the widget will be enlarged to three columns and two more columns to make room for the border. =cut sub _conf { # Validates and initialises the new TextField object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( CAPTION => undef, COLUMNS => 10, LINES => 1, MAXLENGTH => 255, MASK => undef, VALUE => '', INPUTFUNC => \&scankey, BORDER => 1, FOCUSSWITCH => "\t\n", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, READONLY => 0, @_ ); my @required = qw(X Y); my $err = 0; # Check for required arguments foreach (@required) { $err = 1 unless exists $conf{$_} }; # Make sure no errors are returned by the parent method $err = 1 unless $self->SUPER::_conf(%conf); return $err == 0 ? 1 : 0; } =head2 draw $tf->draw($mwh, 1); The draw method renders the text field in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the field's text cursor to be rendered as well. =cut sub _content { my $self = shift; my $dwh = shift; my $cursor = shift; my $conf = $self->{CONF}; my ($pos, $ts, $value, $border, $col) = @$conf{qw(CURSORPOS TEXTSTART VALUE BORDER COLUMNS)}; my $seg; # Trim the value if it exceeds the maximum length $value = substr($value, 0, $$conf{MAXLENGTH}) if $$conf{MAXLENGTH}; # Turn on underlining (terminal-dependent) if no border is used $dwh->attron(A_UNDERLINE) unless $border; # Adjust the cursor position and text start if it's out of whack if ($pos > length($value)) { $pos = length($value); } elsif ($pos < 0) { $pos = 0; } if ($pos > $ts + $$conf{COLUMNS} - 1) { $ts = $pos + 1 - $$conf{COLUMNS}; } elsif ($pos < $ts) { $ts = $pos; } $ts = 0 if $ts < 0; # Write the widget value (adjusting for horizontal scrolling) $seg = substr($value, $ts, $$conf{COLUMNS}); $seg = '*' x length($seg) if $$conf{PASSWORD}; $seg .= ' ' x ($$conf{COLUMNS} - length($seg)); $dwh->addstr(0, 0, $seg); $dwh->attroff(A_BOLD); # Underline the field if no border is used $dwh->chgat(0, 0, $col, A_UNDERLINE, select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0) unless $border; # Save the textstart, cursorpos, and value in case it was tweaked @$conf{qw(TEXTSTART CURSORPOS VALUE)} = ($ts, $pos, $value); } sub _cursor { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; # Display the cursor $dwh->chgat(0, $$conf{CURSORPOS} - $$conf{TEXTSTART}, 1, A_STANDOUT, select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0) unless $$conf{READONLY}; # Restore the default settings $self->_restore($dwh); } sub input_key { # Process input a keystroke at a time. # # Usage: $self->input_key($key); my $self = shift; my $in = shift; my $conf = $self->{CONF}; my $mask = $$conf{MASK}; my ($value, $pos, $max, $ro) = @$conf{qw(VALUE CURSORPOS MAXLENGTH READONLY)}; my @string = split(//, $value); # Process special keys if ($in eq KEY_BACKSPACE) { return if $ro; if ($pos > 0) { splice(@string, $pos - 1, 1); $value = join('', @string); --$pos; } else { beep; } } elsif ($in eq KEY_RIGHT) { $pos < length($value) ? ++$pos : beep; } elsif ($in eq KEY_LEFT) { $pos > 0 ? --$pos : beep; } elsif ($in eq KEY_HOME) { $pos = 0; } elsif ($in eq KEY_END) { $pos = length($value); # Process other keys } else { return if $ro || $in !~ /^[[:print:]]$/; # Exit if it's a non-printing character return unless $in =~ /^[\w\W]$/; # Reject if we're already at the max length if (defined $max && length($value) == $max) { beep; return; # Append to the end if the cursor's at the end } elsif ($pos == length($value)) { $value .= $in; # Insert the character at the cursor's position } elsif ($pos > 0) { @string = (@string[0..($pos - 1)], $in, @string[$pos..$#string]); $value = join('', @string); # Insert the character at the beginning of the string } else { $value = "$in$value"; } # Increment the cursor's position ++$pos; } # Save the changes @$conf{qw(VALUE CURSORPOS)} = ($value, $pos); } 1; =head1 HISTORY =over =item 1999/12/29 -- Original text field widget in functional model =item 2001/07/05 -- First incarnation in OO architecture =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/TextMemo.pm0000644000175000017500000003143607564777120022313 0ustar srzsrz00000000000000# Curses::Widgets::TextMemo.pm -- Text Memo Widgets # # (c) 2001, Arthur Corliss # # $Id: TextMemo.pm,v 1.104 2002/11/14 01:27:31 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets::TextMemo - Text Memo Widgets =head1 MODULE VERSION $Id: TextMemo.pm,v 1.104 2002/11/14 01:27:31 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets::TextMemo; $tm = Curses::Widgets::TextMemo->new({ CAPTION => 'Memo', CAPTIONCOL => 'blue', COLUMNS => 10, MAXLENGTH => undef, LINES => 3, MASK => undef, VALUE => '', INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, X => 1, Y => 1, READONLY => 0, }); $tm->draw($mwh, 1); See the Curses::Widgets pod for other methods. =head1 REQUIREMENTS =over =item Curses =item Curses::Widgets =back =head1 DESCRIPTION Curses::Widgets::TextMemo provides simplified OO access to Curses-based single line text fields. Each object maintains its own state information. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets::TextMemo; use strict; use vars qw($VERSION @ISA); use Carp; use Curses; use Curses::Widgets; ($VERSION) = (q$Revision: 1.104 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widgets); ##################################################################### # # Module code follows # ##################################################################### =head1 METHODS =head2 new (inherited from Curses::Widgets) $tm = Curses::Widgets::TextMemo->new({ CAPTION => 'Memo', CAPTIONCOL => 'blue', COLUMNS => 10, MAXLENGTH => undef, LINES => 3, MASK => undef, VALUE => '', INPUTFUNC => \&scankey, FOREGROUND => 'white', BACKGROUND => 'black', BORDER => 1, BORDERCOL => 'red', FOCUSSWITCH => "\t", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, X => 1, Y => 1, READONLY => 0, }); The new method instantiates a new TextMemo object. The only mandatory key/value pairs in the configuration hash are B and B. All others have the following defaults: Key Default Description ============================================================ CAPTION undef Caption superimposed on border CAPTIONCOL undef Foreground colour for caption text COLUMNS 10 Number of columns displayed MAXLENGTH undef Maximum string length allowed LINES 3 Number of lines in the window VALUE '' Current field text INPUTFUNC \&scankey Function to use to scan for keystrokes FOREGROUND undef Default foreground colour BACKGROUND undef Default background colour BORDER 1 Display a border around the field BORDERCOL undef Foreground colour for border FOCUSSWITCH "\t" Characters which signify end of input CURSORPOS 0 Starting position of the cursor TEXTSTART 0 Line number of string to start displaying PASSWORD 0 Subsitutes '*' instead of characters READONLY 0 Prevents alteration to content The B is only valid when the B is enabled. If the border is disabled, the field will be underlined, provided the terminal supports it. The B has no effect if left undefined. =cut sub _conf { # Validates and initialises the new TextMemo object. # # Usage: $self->_conf(%conf); my $self = shift; my %conf = ( COLUMNS => 10, MAXLENGTH => undef, LINES => 3, VALUE => '', INPUTFUNC => \&scankey, BORDER => 1, UNDERLINE => 1, FOCUSSWITCH => "\t", CURSORPOS => 0, TEXTSTART => 0, PASSWORD => 0, READONLY => 0, @_ ); my @required = qw(X Y); my $err = 0; # Check for required arguments foreach (@required) { $err = 1 unless exists $conf{$_} }; # Make sure no errors are returned by the parent method $err = 1 unless $self->SUPER::_conf(%conf); return $err == 0 ? 1 : 0; } =head2 draw $tm->draw($mwh, 1); The draw method renders the text memo in its current state. This requires a valid handle to a curses window in which it will render itself. The optional second argument, if true, will cause the field's text cursor to be rendered as well. =cut sub _border { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($border, $ts, $pos, $value, $lines) = @$conf{qw(BORDER TEXTSTART CURSORPOS VALUE LINES)}; my (@lines, $v, $i, $y, $x); # Massage the value as needed, and split the result $value = '' unless defined $value; $value = substr($value, 0, $$conf{MAXLENGTH}) if defined $$conf{MAXLENGTH}; @lines = textwrap($value, $$conf{COLUMNS} - 1); # Adjust the cursor position and text start line if they're out of whack $pos = $pos < 0 ? 0 : ($pos > length($value) ? $pos = length($value) : $pos); $ts = $#lines if $ts > $#lines; $ts = 0 if $ts < 0; if ($ts > 0 && $pos < length(join('', @lines[0..($ts - 1)]))) { $v = length(join('', @lines[0..($ts - 1)])); $i = $ts - 1; until ($v <= $pos) { $v -= length($lines[$i]); --$i; } $ts = $i > 0 ? $i : 0; ++$ts unless $pos < length($lines[0]); } elsif ($ts + $lines - 1 < $#lines && $pos >= length(join('', @lines[0..($ts + $lines - 1)]))) { $v = length(join('', @lines[0..($ts + $lines - 1)])); $i = $ts + $lines; until ($v >= $pos) { $v += length($lines[$i]); ++$i; } $ts = $i - $lines; ++$ts if $pos == $v; } ++$ts if $pos == length($value) and $ts + $lines == @lines; # Save the adjust values @$conf{qw(TEXTSTART CURSORPOS VALUE)} = ($ts, $pos, $value); $self->{SPLIT} = [@lines]; # Render the border if ($border) { # Call the parent method $self->SUPER::_border($dwh); # Place the arrows $dwh->getmaxyx($y, $x); $dwh->addch(0, $x - 2, ACS_UARROW) if $ts > 0; $dwh->addch($y - 1, $x - 2, ACS_DARROW) if $#lines - $ts > $lines; } } sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($border, $ts, $pos, $lines, $cols) = @$conf{qw(BORDER TEXTSTART CURSORPOS LINES COLUMNS)}; my @lines = @{$self->{SPLIT}}; my ($i, $j); # Print the lines $j = 0; for ($i = $ts; $i < $ts + $lines; $i++) { unless ($i > $#lines) { $$conf{PASSWORD} ? $dwh->addstr($j, 0, '*' x length($lines[$i])) : $dwh->addstr($j, 0, $lines[$i]) ; } # Underline each line if there's no border $dwh->chgat($j, 0, $cols, A_UNDERLINE, select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0) unless $border; $j++; } } sub _cursor { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; my ($pos, $ts) = @$conf{qw(CURSORPOS TEXTSTART)}; my @lines = @{$self->{SPLIT}}; my $i = 0; my $v = 0; my $seg; $v = length(join('', @lines[0..($ts - 1)])) if $ts > 0; while ($ts + $i < $#lines && $v + length($lines[$ts + $i]) <= $pos) { $v += length($lines[$ts + $i]); ++$i; } $v = $pos - $v; #$i-- if $i > 0 and substr($$conf{VALUE}, $pos - 1, 1) eq "\n"; if ($pos == length($$conf{VALUE}) && substr($$conf{VALUE}, $pos - 1, 1) eq "\n") { ++$i; $v = 0; } $dwh->chgat($i, $v, 1, A_STANDOUT, select_colour(@$conf{qw(FOREGROUND BACKGROUND)}), 0); $self->_restore($dwh); } sub input_key { # Process input a keystroke at a time. # # Usage: $self->input_key($key); my $self = shift; my $in = shift; my $conf = $self->{CONF}; my ($value, $pos, $max, $ro, $ts) = @$conf{qw(VALUE CURSORPOS MAXLENGTH READONLY TEXTSTART)}; my @string = split(//, $value); my @lines = @{$self->{SPLIT}}; my ($snippet, $i, $lpos, $l); # Process special keys if ($in eq KEY_BACKSPACE) { return if $ro; if ($pos > 0) { splice(@string, $pos - 1, 1); $value = join('', @string); --$pos; } else { beep; } } elsif ($in eq KEY_RIGHT) { $pos < length($value) ? ++$pos : beep; } elsif ($in eq KEY_LEFT) { $pos > 0 ? --$pos : beep; } elsif ($in eq KEY_UP || $in eq KEY_DOWN || $in eq KEY_NPAGE || $in eq KEY_PPAGE) { # Exit early if there's no text unless (length($value) > 0) { beep; return; } # Get the text length up to the displayed window $snippet = $ts == 0 ? 0 : length(join('', @lines[0..($ts - 1)])); # Get the position of the cursor relative to the line it's on, # as well as the line index if ($pos == length($value)) { $l = $#lines; $lpos = length($lines[$#lines]); } else { $i = 0; while ($snippet + length($lines[$ts + $i]) <= $pos) { $snippet += length($lines[$ts + $i]); ++$i; } $l = $ts + $i; $lpos = $pos - $snippet; } # Process according to the key if ($in eq KEY_UP) { if ($l > 0) { if (length($lines[$l - 1]) >= $lpos) { $pos -= length($lines[$l - 1]); } else { $pos -= ($lpos + 1); } } else { beep; } } elsif ($in eq KEY_DOWN) { if ($l < $#lines) { if (length($lines[$l + 1]) >= $lpos) { $pos += length($lines[$l]); } else { $pos += ((length($lines[$l]) - $lpos) + length($lines[$l + 1]) - 1); } } else { beep; } } elsif ($in eq KEY_PPAGE) { if ($l >= $$conf{LINES}) { $pos -= length(join('', @lines[(1 + $l - $$conf{LINES})..($l - 1)])); if (length($lines[$l - $$conf{LINES}]) > $lpos) { $pos -= length($lines[$l - $$conf{LINES}]); } else { $pos -= ($lpos + 1); } } elsif ($l > 0) { if ($lpos > length($lines[0])) { $pos = length($lines[0]) - 1; } else { $pos = $lpos; } } else { beep; } } elsif ($in eq KEY_NPAGE) { if ($l <= $#lines - $$conf{LINES}) { $pos += length(join('', @lines[($l + 1) ..($l + $$conf{LINES} - 1)])); if (length($lines[$l + $$conf{LINES}]) >= $lpos) { $pos += (length($lines[$l + $$conf{LINES}]) + 1); } else { $pos += ((length($lines[$l]) - $lpos) + length($lines[$l + $$conf{LINES}]) - 1); } } elsif ($l < $#lines) { if (length($lines[$#lines]) > $lpos) { $pos = length($value) - (length($lines[$#lines]) - $lpos); } else { $pos = length($value); } } else { beep; } } } elsif ($in eq KEY_HOME) { $pos = 0; } elsif ($in eq KEY_END) { $pos = length($value); # Process other keys } else { return if $ro || $in !~ /^[[:print:]]$/; # Exit if it's a non-printing character return unless $in =~ /^[\w\W]$/; # Reject if we're already at the max length if (defined $max && length($value) == $max) { beep; return; # Append to the end if the cursor's at the end } elsif ($pos == length($value)) { $value .= $in; # Insert the character at the cursor's position } elsif ($pos > 0) { @string = (@string[0..($pos - 1)], $in, @string[$pos..$#string]); $value = join('', @string); # Insert the character at the beginning of the string } else { $value = "$in$value"; } # Increment the cursor's position ++$pos; } # Save the changes @$conf{qw(VALUE CURSORPOS TEXTSTART)} = ($value, $pos, $ts); } 1; =head1 HISTORY =over =item 1999/12/29 -- Original text field widget in functional model =item 2001/07/05 -- First incarnation in OO architecture =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets/Tutorial/0000755000175000017500000000000010021050434021755 5ustar srzsrz00000000000000libcurses-widgets-perl-1.997.orig/Widgets/Tutorial/Creation.pod0000644000175000017500000002015207564777120024257 0ustar srzsrz00000000000000# Curses::Widget::Tutorial::Creation.pod -- Widget Creation Tutorial # # (c) 2001, Arthur Corliss # # $Id: Creation.pod,v 0.3 2002/11/04 00:45:06 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widget::Tutorial::Creation -- Widget Creation Tutorial =head1 POD VERSION $Id: Creation.pod,v 0.3 2002/11/04 00:45:06 corliss Exp corliss $ =head1 DESCRIPTION Creating a custom widget is as easy as creating a descendant class of B and defining as few as four methods: Method Purpose ==================================================== _conf Validates configurations options and initialises the internal state/data _content Renders the widget according to the current state _cursor Renders the widget cursor according to the current state input_key Updates the state information according to the passed character input =head2 BASIC MODULE STRUCTURE A decent code template for custom widgets would start with the following (we'll call our new widget B): package MyWidget; use strict; use vars qw($VERSION @ISA); use Curses; use Curses::Widget; ($VERSION) = (q$Revision: 0.3 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Curses::Widget); Please note that the B statment provides more than just a base class to inherit methods from, it also imports standard functions for use in the module: Function Purpose =========================================================== select_colour Initialises new colour pairs, and returns the appropriate colour pair number, for use with $wh->attrset(COLOR_PAIR($n)) calls. select_color, the American English spelling, also works. scankey This blocks until a key is pressed, and that key returned. textwrap Splits the text given into lines no longer than the column limit specified. See the B pod for the specific syntax. Descendent classes will automatically know the following fields (as used by the B or B methods): Field Type Description =========================================================== Y int Y coordinate of upper left corner of widget X int X coordinate of upper left corner of widget LINES int Number of lines in the content area of the widget COLUMNS int Number of columsn inthe content area BORDER boolean Whether to surround the widget with a box CAPTION string Caption to display on top of border FOREGROUND string Default foreground colour BACKGROUND string Default background colour BORDERCOL string Default border foreground colour CAPTIONCOL string Default caption foreground colour The colours, if not specified during widget instantiation, will default to the colours in colour pair 0 (the terminal default). Borders will only be drawn if BORDER is true, and that decision is made in the default B<_border> method, not in the B method. The B<_caption> method also decides internally whether or not to draw itself according to the value of BORDER. =head2 METHOD SEMANTICS The _conf method is called by the class constructor (provided by B, unless you override it here as well). Widget objects should be created with all configuration options passed in a hash ref: $widget = Curses::Widget::MyWidget->new({ OPTION1 => $value1, OPTION2 => $value2, [. . .] }); The configuration hash is dereferenced and passed as arguments to the _conf method inside of the B constructor: $rv = $self->_conf(%$conf); Because of this, the _conf method should probably begin along these lines: sub _conf { my $self = shift; my %conf = ( OPTION1 => default1, OPTION2 => default2, [. . .], @_ ); my $err = 0; # Validate and initialise the widget's state # and store in the %conf hash # Always include the following $err = 1 unless $self->SUPER::_conf(%conf); return ($err == 0) ? 1 : 0; } You should perform any initialisation and validation of the configuration options here. This routine is expected to return a true or false value, depending on whether or not any critical errors were found. A false value will prevent the B constructor from returning an object reference, causing the instantiation request to fail. The last two lines of code should always be included in this subroutine. The call to the parent class' _conf method stores the final initialised state information in %conf in the object field B, after initialising many of the standard colour fields, should they have been left undefined. You can retrieve and update the state information via $self->{CONF}. A copy of that state information will be stored in $self->{OCONF}, and can be restored with a call to B, a method provided by B. The second method you should override is the B<_content> method. This method, as mentioned above, is responsible for rendering the widget according to its state information. This method should handle one arguments: $widget->_content($cwh); The argument will be a window handle to the I of the widget. You should always layout your widget with the upper left corner as (0, 0), since the B method is responsible for allocating any extra space needed for borders and captions. If your widget doesn't support borders and/or captions you can do one of two things: override those methods (B<_border> and B<_caption>) to immediately return without doing anything, or override the B method to exclude those calls. Typically, the former method of handling this would be preferred. The third method you need to override is the B<_cursor> method. This accepts the same window handle as the B<_content> method. The default B method will only call this method if it was called with a true I argument. Neither of these two methods will need to allocate, refresh, or destroy window handles, just print the content. The windows will already be erased and initialised to specified foreground/background pairs, and those settings saved via the B<_save> method. If at any time you need to reset the window handle's current cursor back to those settings you can call B<_restore>: $self->_restore($dwh); In fact, in order to make the state of the window handle more predictable for descendent classes you should probably call _restore at the end of each of these methods. The final method that should be overridden is the input_key method. This expects a single argument, that being the keystroke captured by the keyboard scanning function. It uses that value to update (if it's not rejected) the widget's state information. A rough skeleton for this function would be as follows: sub input_key { my $self = shift; my $key = shift; my $conf = $self->{CONF}; # validate/update state information } =head2 CONCLUSION That, in a nutshell, is all there is to creating a custom widget. For a working example which uses the structure noted above, look at the TextField or ButtonSet widgets. Both consist of nothing more than the routines listed above. =head1 HISTORY 2001/07/07 -- First draft. 2002/11/01 -- Updated for reworked internals. =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com), =cut libcurses-widgets-perl-1.997.orig/Widgets/Tutorial.pod0000644000175000017500000001435507564777120022523 0ustar srzsrz00000000000000# Curses::Widget::Tutorial.pod -- Widget Usage Tutorial # # (c) 2001, Arthur Corliss # # $Id: Tutorial.pod,v 1.2 2002/11/04 00:44:04 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widget::Tutorial -- Widget Usage Tutorial =head1 POD VERSION $Id: Tutorial.pod,v 1.2 2002/11/04 00:44:04 corliss Exp corliss $ =head1 DESCRIPTION Usage of any given widget is fairly simple, but plenty of flexibility is built into the system in order to allow you to completely control every aspect of their behaviour. =head2 ENVIRONMENT Due to the usage of Curses constants and the way that the screen is controlled, care must be taken in how the running environment is set up. To begin, one would initiate a Curses session on the console in a typical fashion: $mwh = new Curses; We then turn off echoing, since the widgets will determine what and were any input is sent to the display: noecho(); I typically use half-blocking input reads, since there may be periodic routines that I want to run while waiting for input. If you're comfortable with that, you can do the same: halfdelay(5); Next, I turned on cooked input, since the widgets make heavy use of constants for recognising special keys: $mwh->keypad(1); Finally, we set the cursor visibility to invisible, since the widgets will provide their own as necessary: curs_set(0); From this point, we're not ready to start splashing widgets to the screen and start handling input. =head1 USAGE INSTRUCTIONS =head2 BASIC USAGE When using the widgets, you must have B line for each type of widget used in your program. In addition, it's good practice to include the base class as well, since it provides some useful functions for handling both reading input and managing colour pairs. Example: ======== use Curses; use Curses::Widgets; use Curses::Widgets::TextField; # Initialise the environment $mwh = new Curses; noecho(); halfdelay(5); $mwh->keypad(1); curs_set(0); Next, we instantiate the widget(s) we want to use. $tf = Curses::Widgets::TextField->new({ X => 5, Y => 5, COLUMNS => 10, CAPTION => 'Login' }); One thing you need to remember is that B (and B, for those widgets that support it) always pertain to the I area in the widget. If the widget supports a bordered mode, the actual dimensions will increase by two in both the Y and the X axis. In other words, since TextFields have borders on by default, the actual number of columns and lines that will be used by the above widget is 10 and 3, respectively. To cause the widget to display itself, call the B method: $tf->draw($mwh, 0); The first argument is a handle to the window in which you want the widget to draw itself. All widgets are drawn in derived windows. The second argument should be a Perlish boolean value which instructs the draw method whether or not to draw the cursor. When you're ready to accept input, the simplest method is to use the B method: $tf->execute($mwh); This method is a blocking call until the widget is fed a character matching the class defined by FOCUSSWITCH ([\n\t] by default). Until it recieves a matching character, the widget will respond appropriately to all user input and update the display automatically. Once the B method call exits, you can retrieve the final value of the widget via the B method: $login = $tf->getField('VALUE'); =head2 ADVANCED USAGE You may have a need to run period routines while waiting for (or handling) user input. The simplest way add this functionality is to create your own input handler. The default handler (provided by Curses::Widgets: B) is coded as such: sub scankey { my $mwh = shift; my $key = -1; while ($key eq -1) { $key = $mwh->getch; } return $key; } If, for example, we wanted that function to update a clock (the actual code for which we'll pretend is in the B function) we could insert that call inside of our new input handler's while loop: sub myscankey { my $mwh = shift; my $key = -1; while ($key eq -1) { $key = $mwh->getch; update_clock($mwh); } return $key; } We can then hand this function to the widgets during instantiation, or via the B method: $tf = Curses::Widgets::TextField->new({ X => 5, Y => 5, INPUTFUNC => \&myscankey }); -- Or -- $tf->setField(INPUTFUNC => \&myscankey); Another way to handle this is to set up your own loop, and instead of each widget calling it privately, handle all input yourself, sending it to the appropriate widget via each widget's B method: while (1) { while ($key eq -1) { $key = $mwh->getch; update_clock($mwh); } # Send numbers to one field if ($key =~ /^\d$/) { $tf1->input($key); # Send alphas to another } elsif ($key =~ /^\w$/) { $tf2->input($key); # Send KEY_UP/DOWN to a list box } elsif ($key eq KEY_UP || $key eq KEY_DOWN) { $lb->input($key); } # Update the display foreach ($tf1, $tf2, $lb) { $_->draw($mwh, 0); } } This is a rather simplistic example, but hopefully the applications of this are obvious. One could easily set hot key sequences for switching focus to various widgets, or use input from one widget to update another, and so on. =head2 CONCLUSION That, in a nutshell, is how to use the widgets. Hopefully the system is flexible enough to be bound to the event model and input systems of your choice. =head1 HISTORY 2001/12/09 -- First draft. =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/Widgets.pm0000644000175000017500000006134207564777111020550 0ustar srzsrz00000000000000# Curses::Widgets.pm -- Base widget class for use with the # Curses::Application framework # # (c) 2001, Arthur Corliss # # $Id: Widgets.pm,v 1.997 2002/11/14 01:30:19 corliss Exp corliss $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ##################################################################### =head1 NAME Curses::Widgets - Base widget class for use with the Curses::Application framework =head1 MODULE VERSION $Id: Widgets.pm,v 1.997 2002/11/14 01:30:19 corliss Exp corliss $ =head1 SYNOPSIS use Curses::Widgets; $rv = test_colour(); test_color(); $colpr = select_colour($fore, $back); $colpr = select_color($fore, $back); $key = scankey($mwh); @lines = textwrap($text, 40); # The following are provided for use with descendent # classes, and while they are not expected to be # overridden, they can be. $obj = Curses::Widgets->new({KEY => 'value'}); $obj->_copy($href1, $href2); $obj->reset; $obj->input($string); $value = $obj->getField('VALUE'); $obj->setField( 'FIELD1' => 1, 'FIELD2' => 'value' ); $obj->execute($mwh); $obj->draw($mwh, 1); @geom = $obj->_geometry; @geom = $obj->_cgeometry; $dwh = $obj->_canvas($mwh, @geom); $obj->_save($mwh); $obj->_restore($mwh); $obj->_border($mwh); $obj->_caption # The following are provided for use with descendent # classes, and are expected to be overridden. $obj->_conf(%conf); $obj->input_key($ch); $obj->_content($mwh); $obj->_cursor =head1 REQUIREMENTS =over =item Curses =back =head1 DESCRIPTION This module serves two purposes: to provide a framework for creating custom widget classes, and importing a few useful functions for global use. Widget specific methods are documented in each Widget's pod, of which the following widgets are currently available: =over =item Button Set (Curses::Widgets::ButtonSet) =item Calendar (Curses::Widgets::Calendar) =item Combo-Box (Curses::Widgets::ComboBox) =item Label (Curses::Widgets::Label) =item List Box (Curses::Widgets::ListBox) =item Multicolumn List Box (Curses::Widgets::ListBox::MultiColumn) =item Menu (Curses::Widgets::Menu) =item Progress Bar (Curses::Widgets::ProgressBar) =item Text Field (Curses::Widgets::TextField) =item Text Memo (Curses::Widgets::TextMemo) =back The following tutorials are available: =over =item Widget Usage -- General Usage & Tips (Curses::Widgets::Tutorial) =item Widget Creation (Curses::Widgets::Tutorial::Creation) =item Widget Creation -- ComboBox Example (Curses::Widgets::Tutorial::ComboBox) =back For even higher (and simpler) level control over collections of widgets on "forms", please see B, which uses this module as well. =cut ##################################################################### # # Environment definitions # ##################################################################### package Curses::Widgets; use strict; use vars qw($VERSION @ISA @EXPORT); use Carp; use Curses; use Exporter; ($VERSION) = (q$Revision: 1.997 $ =~ /(\d+(?:\.(\d+))+)/); @ISA = qw(Exporter); @EXPORT = qw(select_colour select_color scankey textwrap); my $colour = -1; my %colours = ( black => COLOR_BLACK, cyan => COLOR_CYAN, green => COLOR_GREEN, magenta => COLOR_MAGENTA, red => COLOR_RED, white => COLOR_WHITE, yellow => COLOR_YELLOW, blue => COLOR_BLUE ); my %colour_pairs = (); my ($DEFAULTFG, $DEFAULTBG); ##################################################################### # # Module code follows # ##################################################################### =head1 EXPORTED FUNCTIONS =head2 test_colour/test_color $rv = test_colour(); test_color(); This function tests the console for colour capability, and if found, it will set B<$Curses::Widgets::DEFAULTFG> and B<$Curses::Widgets::DEFAULTBG> to the default foreground and background colour, respectively. It also calls the Curses B for you. Unless you need to know the default foreground/background colours ahead of time, you won't need to call this, B will do it for you the first time it's called, if necessary. This function returns a true or false, designating colour support. =cut sub test_colour { my ($df, $db); if (has_colors) { start_color; pair_content(0, $df, $db); foreach (keys %colours) { $df = $_ and last if $df == $colours{$_} }; foreach (keys %colours) { $db = $_ and last if $db == $colours{$_} }; $colour_pairs{"$df:$db"} = 0; $colour = 1; ($DEFAULTFG, $DEFAULTBG) = ($df, $db); } else { $colour = 0; } return $colour; } sub test_color { return test_colour(); } =head2 select_colour/select_color $colpr = select_colour($fore, $back); $colpr = select_color($fore, $back); This function returns the number of the specified colour pair. In doing so, it saves quite a few steps. After the initial colour test, this function will safely (and quietly) return on all subsequent calls if no colour support is found. It returns '0', which is hardwired to your terminal default. If colour support is present, it allocates the colour pair using (n)curses B for you, if it hasn't been done already. Most terminals have a limited number of colour pairs that can be defined. Because of this 0 (the terminal default colour pair) will be returned in lieu of attempting to allocate more colour pairs than the terminal supports. If you need a specific set of colours to be available, you might want allocate each pair ahead of time using this function to prevent less important pairs from running you out of pairs. As a final note, yes, both the British and American spellings of 'colo(u)r' are supported. Known colours: black cyan green magenta red white yellow blue The colours are not case sensitive. =cut sub select_colour { my ($fore, $back) = @_; my (@pairs, $pr); # Check for colour support if $colours is -1 if ($colour == -1) { test_colour(); # Take an early exit unless the terminal supports colour } elsif ($colour == 0) { return 0; } # Set the background colour if it was omitted $back = $DEFAULTBG unless defined $back; # Lowercase both arguments ($fore, $back) = (lc($fore), lc($back)); # Check to see if the colour pair has already been defined unless (exists $colour_pairs{"$fore:$back"}) { # Exit out if we're out of colour pairs (returning the default pair) unless (scalar keys %colour_pairs < $COLOR_PAIRS) { return 0; } # Define a new colour pair if valid colours were passed if (exists $colours{$fore} && exists $colours{$back}) { @pairs = map { $colour_pairs{$_} } keys %colour_pairs; $pr = 1; while (grep /^$pr$/, @pairs) { ++$pr }; init_pair($pr, @colours{$fore, $back}); $colour_pairs{"$fore:$back"} = $pr; # Generate a warning if invalid colours were passed } else { carp "Invalid color pair passed: $fore/$back--ignoring."; return undef; } } # Return the colour pair number return $colour_pairs{"$fore:$back"}; } sub select_color { my @args = @_; return select_colour(@_); } =head2 scankey $key = scankey($mwh); The scankey function returns the key pressed, when it does. All it does is loop over a (n)curses B call until something other than -1 is returned. Whether or not the B call is (half)-blocking or cooked output is determined by how the (n)curses environment was initialised by your application. This is provided only to provide the most basic input functionality to your application, should you decide not to implement your own. The only argument is a handle to a curses/window object. =cut sub scankey { my $mwh = shift; my $key = -1; while ($key eq -1) { $key = $mwh->getch }; return $key; } =head2 textwrap @lines = textwrap($text, 40); The textwrap function takes a string and splits according to the passed column limit, splitting preferrably along whitespace. Newlines are preserved. =cut sub textwrap { my $text = shift; my $columns = shift || 72; my (@tmp, @rv, $p); # Early exit if no text was passed return unless (defined $text && length($text)); # Split the text into paragraphs, but preserve the terminating newline @tmp = split(/\n/, $text); foreach (@tmp) { $_ .= "\n" }; chomp($tmp[$#tmp]) unless $text =~ /\n$/; # Split each paragraph into lines, according to whitespace for $p (@tmp) { # Snag lines that meet column limits (not counting newlines # as a character) if (length($p) <= $columns || (length($p) - 1 <= $columns && $p =~ /\n$/s)) { push(@rv, $p); next; } # Split the line while (length($p) > $columns) { if (substr($p, 0, $columns) =~ /^(.+\s)(\S+)$/) { push(@rv, $1); $p = $2 . substr($p, $columns); } else { push(@rv, substr($p, 0, $columns)); substr($p, 0, $columns) = ''; } } push(@rv, $p); } if ($text =~ /\S\n(\n+)/) { $p = length($1); foreach (1..$p) { push(@rv, "\n") }; } return @rv; } =head1 METHODS =head2 new $obj = Curses::Widgets->new({KEY => 'value'}); The new class method provides a basic constructor for all descendent widget classes. Internally, it assumes any configuration information to be passed in a hash ref as the sole argument. It dereferences that ref and passes it to the internal method B<_conf>, which is expected to do any input validation/initialisation required by your widget. That method should return a 1 or 0, which will determine if B returns a handle to the new object. If B<_conf> returns a 1, the B<_copy> is called to back up the initial state information. If descendent widgets use the methods provided in the class (instead of overriding them) then the following keys should always be recognised: Key Description ==================================================== FOREGROUND Foreground colour BACKGROUND Background colour BORDERCOL Border (foreground) colour CAPTIONCOL Caption (foreground) colour BORDER Whether or not to display a border CAPTION The string to use as the caption The colours will default to the terminal foreground/background defaults. Other arguments may have defaults defined by the descendent classes. =cut sub new { my $class = shift; my $conf = shift; my $self = {}; bless $self, $class; if ($self->_conf(%$conf)) { $self->_copy($self->{CONF}, $self->{OCONF}); return $self; } else { return undef; } } =head2 _conf $obj->_conf(%conf); This method should be overridden in your descendant class. As mentioned above, it should do any initialisation and validation required, based on the passed configuration hash. It should return a 1 or 0, depending on whether any critical errors were encountered during instantiation. B your B<_conf> method should call, as a last act, B. This is important to do, since this method takes care of some colour initialisation steps for you automatically. The following keys are known by this module, and are used by certain rendering and initiation methods: Field Default Description ============================================================ FOREGROUND (terminal default) Default foreground colour BACKGROUND (terminal default) Default background colour BORDERCOL (FOREGROUND) Default border colour CAPTIONCOL (FOREGROUND) Default caption colour As a final note, here are some rules regarding the structure of your configuration hash. You *must* save your state information in this hash. Another subroutine will copy that information after object instantiation in order to support the reset method. Also note that everything stored in this should *not* be more than one additional level deep (in other words, values can be hash or array refs, but none of the values in *that* structure should be refs), otherwise those refs will be copied over, instead of the data inside the structure. This essentially destroys your backup. If you have special requirements, override the _copy method as well. =cut sub _conf { my $self = shift; my %conf = @_; my ($df, $db, $c); # Set the foreground/background, if it wasn't set already pair_content(0, $df, $db); $conf{FOREGROUND} = (grep { $colours{$_} == $df } keys %colours)[0] unless (exists $conf{FOREGROUND}); $conf{BACKGROUND} = (grep { $colours{$_} == $db } keys %colours)[0] unless (exists $conf{BACKGROUND}); $conf{BORDERCOL} = $conf{FOREGROUND} unless exists $conf{BORDERCOL}; $conf{CAPTIONCOL} = $conf{FOREGROUND} unless exists $conf{CAPTIONCOL}; # Lowercase all colours foreach (qw(FOREGROUND BACKGROUND CAPTIONCOL BORDERCOL)) { $conf{$_} = lc($conf{$_}) }; # Save conf hashes $self->{CONF} = {%conf}; $self->{OCONF} = {}; return 1; } =head2 _copy $obj->_copy($href1, $href2); This method copies the contents of $href1 to $href2. This will only copy two levels of data, so any reference values deeper than that will be passed by reference, not as a copy of reference's (dereferenced) value. =cut sub _copy { # Synchronises the current data record with the old # data record. # # Internal use only. my $self = shift; my ($data, $odata) = @_; my $field; # Empty the target hash %$odata = (); # Copy each element to the target foreach $field (keys %$data) { if (ref($$data{$field}) eq 'ARRAY') { $$odata{$field} = [ @{$$data{$field}} ]; } elsif (ref($$data{$field}) eq 'HASH') { $$odata{$field} = { %{$$data{$field}} }; } else { $$odata{$field} = $$data{$field}; } } } =head2 reset $obj->reset; The reset method resets the object back to the original state by copying the original configuration information into the working hash. =cut sub reset { my $self = shift; # Reset the widget to it's original instantiated state $self->_copy($self->{OCONF}, $self->{CONF}); } =head2 input_key $obj->input_key($ch); The input_key method should be overridden in all descendent classes. This method should accept character input and update it's internal state information appropriately. This method will be used in both interactive and non-interactive modes to send keystrokes to the widget. =cut sub input_key { my $self = shift; my $input; return 1; } =head2 input $obj->input($string); The input method provides a non-interactive method for sending input to the widget. This is essentially just a wrapper for the B method, but will accept any number of string arguments at once. It splits all of the input into separate characters for feeding to the B method. =cut sub input { my $self = shift; my @input = @_; my ($i, @char); while (defined ($i = shift @input)) { if (length($i) > 1) { @char = split(//, $i); foreach (@char) { $self->input_key($_) }; } else { $self->input_key($i); } } } =head2 execute $obj->execute($mwh); This method puts the widget into interactive mode, which consists of calling the B method, scanning for keyboard input, feeding it to the B method, and redrawing. execute uses the widget's configuration information to allow easy modification of its behavoiur. First, it checks for the existance of a INPUTFUNC key. Setting its value to a subroutine reference allows you to substitute any custom keyboard scanning/polling routine in leiu of the default B provided by this module. Second, it checks the return value of the input function against the regular expression stored in FOCUSSWITCH, if any. Any matches against that expression will tell this method to exit, returning the key that matches it. This effectively causes the widget to 'lose focus'. The only argument is a handle to a valid curses window object. B: If \t is in your regex, KEY_STAB will also be a trigger for a focus switch. =cut sub execute { my $self = shift; my $mwh = shift; my $conf = $self->{CONF}; my $func = $$conf{'INPUTFUNC'} || \&scankey; my $regex = $$conf{'FOCUSSWITCH'}; my $key; $self->draw($mwh, 1); while (1) { $key = &$func($mwh); if (defined $key) { if (defined $regex) { return $key if ($key =~ /^[$regex]/ || ($regex =~ /\t/ && $key eq KEY_STAB)); } $self->input_key($key); } $self->draw($mwh, 1); } } =head2 getField $value = $obj->getField('VALUE'); The getField method retrieves the value(s) for every field requested that exists in the configuration hash. =cut sub getField { my $self = shift; my @fields = @_; my $conf = $self->{CONF}; my @results; foreach (@fields) { if (exists $$conf{$_}) { push(@results, $$conf{$_}); } else { carp ref($self), ": attempting to read a non-existent field!"; } } return scalar @results > 1 ? @results : $results[0]; } =head2 setField $obj->setField( 'FIELD1' => 1, 'FIELD2' => 'value' ); The setField method sets the value for every key/value pair passed. =cut sub setField { my $self = shift; my %fields = (@_); my $conf = $self->{CONF}; foreach (keys %fields) { if (exists $$conf{$_}) { $$conf{$_} = $fields{$_}; } else { carp ref($self), ": attempting to set a non-existent field!"; } } } =head2 draw $obj->draw($mwh, 1); The draw method can be overridden in each descendant class. It is reponsible for the rendering of the widget, and only that. The first argument is mandatory, being a valid window handle with which to create the widget's derived window. The second is optional, but if set to true, will tell the widget to draw itself in an 'active' state. For instance, the TextField widget will also render a cursor, while a ButtonSet widget will render the selected button in standout mode. The rendering sequence defined in this class is as follows: # Get the canvas geometry and create a window handle to it $dwh = $self->_canvas($mwh, $self->_geometry); return 0 unless $dwh; $self->_init($dwh); $self->_border($dwh); $self->_caption($dwh); # Get the content area geometry and create a window handle to it $cwh = $self->_canvas($dwh, $self->_cgeometry); unless (defined $cwh) { $dwh->delwin; return 0; } $self->_content($cwh); $self->_cursor($cwh) if $active; =cut sub draw { my $self = shift; my $mwh = shift; my $active = shift; my (@geom, $dwh, $cwh); # Get the canvas geometry and create a window handle to it $dwh = $self->_canvas($mwh, $self->_geometry); return 0 unless $dwh; $self->_init($dwh); $self->_border($dwh); $self->_caption($dwh); # Get the content area geometry and create a window handle to it $cwh = $self->_canvas($dwh, $self->_cgeometry); unless (defined $cwh) { $dwh->delwin; return 0; } $self->_content($cwh); $self->_cursor($cwh) if $active; # Flush the changes to the screen and release the window handles $cwh->refresh; $cwh->delwin; $dwh->refresh; $dwh->delwin; return 1; } =head2 _geometry @geom = $obj->_geometry; This method returns the size of the canvas, with dimensions adjusted to account for a border (based on the value of B in the configuration hash). =cut sub _geometry { my $self = shift; my $conf = $self->{CONF}; my @rv; @rv = @$conf{qw(LINES COLUMNS Y X)}; if ($$conf{BORDER}) { $rv[0] += 2; $rv[1] += 2; } return @rv; } =head2 _cgeometry @geom = $obj->_cgeometry; This method returns the size of the content area. The Y and X coordinates are adjusted appropriately for rendering in a widget canvas. (0, 0) is returned for widgets with no border, and (1, 1) is returned for widgets with a border (based on the value of B in the configuration hash). =cut sub _cgeometry { my $self = shift; my $conf = $self->{CONF}; my @rv; @rv = (@$conf{qw(LINES COLUMNS)}, 0, 0); @rv[2,3] = (1, 1) if $$conf{BORDER}; return @rv; } =head2 _canvas $dwh = $obj->_canvas($mwh, @geom); This method returns a window handle to a derived window in the passed window, using the specified geometry. This will return undef and produce a warning if the call fails for any reason. =cut sub _canvas { my $self = shift; my $mwh = shift; my @geom = @_; my $dwh; carp ref($self), ": Window creation failed, possible geometry problem" unless ($dwh = $mwh->derwin(@geom)); return $dwh; } =head2 _init $obj->_init($mwh); This method erases the window and sets the foreground/background colours as found in the configuration hash. =cut sub _init { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; $dwh->keypad(1); $dwh->bkgdset(COLOR_PAIR(select_colour( @$conf{qw(FOREGROUND BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{FOREGROUND} eq 'yellow'; $dwh->erase; $self->_save($dwh); } =head2 _save $obj->_save($mwh); This method saves the current attributes and colour pair in the passed window. This method would typically be called by the draw routine after _init is called on the derived window (though the current _init method calls this for you). =cut sub _save { my $self = shift; my $dwh = shift; my $conf = shift; my ($attr, $cp); # WARNING! Compatibility hack for some system curses implementation # coming. . . # I'd really like to do this. . . if ($dwh->can('attr_get')) { $dwh->attr_get($attr, $cp, 0); # but if I can't, I'll just hope the window defaults are right } else { $cp = select_colour(@$conf{qw(FOREGROUND BACKGROUND)}); $attr = $$conf{FOREGROUND} eq 'yellow' ? A_BOLD : 0; } $self->{ATTR} = [$attr, $cp]; } =head2 _restore $obj->_restore($mwh); This method restores the last saved attributes and colour pair used in the window. This should be called at the end of any rendering phase that may alter the default colour and attribute settings. =cut sub _restore { my $self = shift; my $dwh = shift; # WARNING! Compatibility hack for some system curses implementation # coming. . . # I'd really like to do this, too. . . if ($dwh->can('attr_set')) { $dwh->attr_set(@{$self->{ATTR}}, 0); # but if you're going to be that way, I'll do it the longer way } else { $dwh->attrset(COLOR_PAIR($self->{ATTR}->[1])); $dwh->attron($self->{ATTR}->[0]); } } =head2 _border $obj->_border($mwh); This method draws the border around the passed window if B is true within the configuration hash. =cut sub _border { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; if ($$conf{BORDER}) { $dwh->attrset(COLOR_PAIR( select_colour(@$conf{qw(BORDERCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{BORDERCOL} eq 'yellow'; $dwh->box(ACS_VLINE, ACS_HLINE); $self->_restore($dwh); } } =head2 _caption $obj->_caption This method draws a caption on the first line of the passed window if B is defined within the configuration hash. =cut sub _caption { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; if (defined $$conf{CAPTION}) { $dwh->attrset(COLOR_PAIR( select_colour(@$conf{qw(CAPTIONCOL BACKGROUND)}))); $dwh->attron(A_BOLD) if $$conf{CAPTIONCOL} eq 'yellow'; $dwh->addstr(0, 1, substr($$conf{CAPTION}, 0, $$conf{COLUMNS})); $self->_restore($dwh); } } =head2 _content $obj->_content($mwh); This method should be overridden in all descendent classes, and should render any content in the passed window. The B method, as defined in this class, will pass a window the exact size of the content area, so no adjustments will need to be made to accomodate a border. =cut sub _content { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; # Override this method to render widget content } =head2 _cursor $obj->_cursor This method should be overriden in all descendent classes that display a cursor in the content area. The B method, as defined in this class, calls this method after the content is rendered, and passes it a window handle the exact size of the content area. =cut sub _cursor { my $self = shift; my $dwh = shift; my $conf = $self->{CONF}; # Override this method to render widget cursor } 1; =head1 HISTORY =over =item 2001/07/05 -- First implementation of the base class. =back =head1 AUTHOR/COPYRIGHT (c) 2001 Arthur Corliss (corliss@digitalmages.com) =cut libcurses-widgets-perl-1.997.orig/test.pl0000755000175000017500000002031707564777111020120 0ustar srzsrz00000000000000#!/usr/bin/perl -w # # Simple script that demonstrates the uses of Curses::Widgetss # # $Id: test.pl,v 1.104 2002/11/14 01:36:48 corliss Exp corliss $ # use strict; use Curses; use Curses::Widgets; # Included to import select_colour & scankey use Curses::Widgets::TextField; use Curses::Widgets::ButtonSet; use Curses::Widgets::ProgressBar; use Curses::Widgets::TextMemo; use Curses::Widgets::ListBox; use Curses::Widgets::Calendar; use Curses::Widgets::ComboBox; use Curses::Widgets::Menu; use Curses::Widgets::Label; ##################################################################### # # Set up the environment # ##################################################################### my ($mwh, $key, $i, $p); my (@widgets, @descriptions); ##################################################################### # # Program Logic starts here # ##################################################################### # Unless specifically noted, most functions are provided by the Curses # package, *not* Curses::Widgets. See the pod for Curses for more # information on the functions. Additional information is available # with the (n)Curses man pages (section 3), if you have them. $mwh = new Curses; noecho(); halfdelay(5); $mwh->keypad(1); $mwh->syncok(1); curs_set(0); leaveok(1); # Draw the main window, and wait for a key press (the scankey # function is imported from the Curses::Widgets module) main_win(); comment_box(<< '__EOF__'); Welcome to the Curses::Widgets Test Script! Press any key to begin. __EOF__ $key = scankey($mwh); # Create each of the widgets beforehand $widgets[0] = Curses::Widgets::Menu->new({ FOREGROUND => 'white', BACKGROUND => 'green', BORDER => 1, CURSORPOS => [qw(File)], MENUS => { MENUORDER => [qw(File Help)], File => { ITEMORDER => [qw(Open Save Exit)], Open => sub { 1 }, Save => sub { 1 }, Exit => sub { exit 0 }, }, Help => { ITEMORDER => [qw(Help About)], Help => sub { 1 }, About => sub { 1 }, }, }, }); $descriptions[0] = << '__EOF__'; Curses::Widgets::Menu -- Menus Use the arrow keys to navigate, and to exit a menu without selecting anything. Use to move to the next widget. __EOF__ $widgets[1] = Curses::Widgets::ButtonSet->new({ Y => 2, X => 2, FOREGROUND => 'white', BACKGROUND => 'black', BORDER => 0, LABELS => [ qw( OK CANCEL HELP ) ], LENGTH => 8, HORIZONTAL => 1, }); $descriptions[1] = << '__EOF__'; Curses::Widgets::ButtonSet -- Horizontal set without borders. Use the arrow keys to navigate among the buttons, and press or to move to the next widget (set). __EOF__ $widgets[2] = Curses::Widgets::ButtonSet->new({ Y => 3, X => 1, FOREGROUND => 'white', BACKGROUND => 'blue', BORDER => 1, LABELS => [ qw( Button1 Button2 Button3 Quit ) ], LENGTH => 9, HORIZONTAL => 0, }); $descriptions[2] = << '__EOF__'; Curses::Widgets::ButtonSet -- Vertical set with borders. Use the arrow keys to navigate among the buttons, and press or to move to the next widget (set). __EOF__ $widgets[3] = Curses::Widgets::TextField->new({ Y => 4, X => 14, COLUMNS => 20, MAXLENGTH => 30, FOREGROUND => 'green', BACKGROUND => 'blue', VALUE => 'Test Value', BORDERCOL => 'black', BORDER => 1, CAPTION => 'Test Field', CAPTIONCOL => 'yellow', }); $descriptions[3] = << '__EOF__'; Curses::Widgets::TextField -- Text field with a border and caption. Press or to move to the next widget (set). __EOF__ $widgets[4] = Curses::Widgets::ProgressBar->new({ Y => 7, X => 14, LENGTH => 20, FOREGROUND => 'yellow', BACKGROUND => 'green', BORDER => 1, BORDERCOL => 'black', CAPTION => 'Progress', CAPTIONCOL => 'white', }); $descriptions[4] = << '__EOF__'; Curses::Widgets::ProgressBar -- Horizontal progress bar with border. Please wait until the bar progresses to 100%. __EOF__ $p = << "__EOF__"; This is an example memo that uses the Widgets class textwrap function to split according to whitespace and column limits. __EOF__ $widgets[5] = Curses::Widgets::TextMemo->new({ Y => 10, X => 14, COLUMNS => 20, FOREGROUND => 'green', BACKGROUND => 'blue', VALUE => $p, BORDERCOL => 'black', BORDER => 1, CAPTION => 'Test Memo', CAPTIONCOL => 'yellow', }); $descriptions[5] = << '__EOF__'; Curses::Widgets::TextMemo -- Text memo with a border and caption. Press or to move to the next widget (set). __EOF__ $widgets[6] = Curses::Widgets::ListBox->new({ Y => 2, X => 38, COLUMNS => 20, LISTITEMS => ['Ham', 'Eggs', 'Cheese', 'Hash Browns', 'Toast'], MULTISEL => 1, VALUE => [0, 2], SELECTEDCOL => 'green', CAPTION => 'List Box', CAPTIONCOL => 'yellow', }); $descriptions[6] = << '__EOF__'; Curses::Widgets::ListBox -- This list box supports multiple and single selection modes. Use or to toggle a selection. Press to move to the next widget (set). __EOF__ $widgets[7] = Curses::Widgets::Calendar->new({ Y => 7, X => 38, FOREGROUND => 'black', BACKGROUND => 'white', BORDER => 1, CAPTION => 'Appointments', CAPTIONCOL => 'blue', HIGHLIGHT => [1, 5, 17, 26], HIGHLIGHTCOL => 'green', HEADERCOL => 'red', }); $descriptions[7] = << '__EOF__'; Curses::Widgets::Calendar -- This calendar supports date highlighting and broad navigation capabilities. Press to move to the next widget (set). __EOF__ $widgets[8] = Curses::Widgets::ComboBox->new({ Y => 3, X => 62, FOREGROUND => 'white', BACKGROUND => 'red', LISTITEMS => [qw(Mr. Mrs. Ms.)], COLUMNS => 4, BORDER => 1, }); $descriptions[8] = << '__EOF__'; Curses::Widgets::ComboBox -- This is a text field that also has a drop-down list to select values from. Just press the down arrow. Press to move to the next widget (set). __EOF__ # Draw each of the widgets foreach (@widgets) { $_->draw($mwh) }; comment_box(); # Interactively demonstrate each widget for ($i = 0; $i < scalar @widgets; $i++) { comment_box($descriptions[$i]); if (ref($widgets[$i]) !~ /Progress/) { $widgets[$i]->execute($mwh); $widgets[$i]->draw($mwh); } else { while ($widgets[$i]->getField('VALUE') < $widgets[$i]->getField('MAX')) { $widgets[$i]->input(30); $widgets[$i]->draw($mwh); sleep 1; } } } # Label description comment_box(<< '__EOF__'); This comment box has been demonstrating the use of the Curses::Widgets::Label. Labels support left, centered, and right alignments, and with and without borders. Press any key to continue. __EOF__ scankey($mwh); # Parting comments comment_box(<< '__EOF__'); This concludes the Curses::Widgets demonstration. Please send all comments, suggestions, criticisms, and bug reports to corliss@digitalmages.com. Press any key to exit. __EOF__ scankey($mwh); exit 0; END { # The END block just ensures that Curses always cleans up behind # itself endwin(); } exit 0; ##################################################################### # # Subroutines follow here # ##################################################################### sub main_win { $mwh->erase(); # This function selects a few common colours for the foreground colour $mwh->attrset(COLOR_PAIR(select_colour(qw(red black)))); $mwh->box(ACS_VLINE, ACS_HLINE); $mwh->attrset(0); $mwh->standout(); $mwh->addstr(0, 1, "Welcome to the Curses::Widgets " . "v${Curses::Widgets::VERSION} Demo!"); $mwh->standend(); } sub comment_box { my $message = shift; my ($cwh, $y, $x, @lines, $i, $line); my $label; # Get the main screen max y & X $mwh->getmaxyx($y, $x); # Render the comment box $label = Curses::Widgets::Label->new({ CAPTION => 'Comments', BORDER => 1, LINES => 5, COLUMNS => $x - 4, Y => $y - 8, X => 1, VALUE => $message, FOREGROUND => 'white', BACKGROUND => 'blue', }); $label->draw($mwh); }