Curses-UI-0.9609/0000755000175000001440000000000011630214052012252 5ustar mdxiusersCurses-UI-0.9609/lib/0000755000175000001440000000000011630214052013020 5ustar mdxiusersCurses-UI-0.9609/lib/Curses/0000755000175000001440000000000011630214052014264 5ustar mdxiusersCurses-UI-0.9609/lib/Curses/UI/0000755000175000001440000000000011630214052014601 5ustar mdxiusersCurses-UI-0.9609/lib/Curses/UI/Searchable.pm0000644000175000001440000002635511627564365017230 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Searchable # Curses::UI::SearchEntry # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox # ---------------------------------------------------------------------- # SearchEntry package # ---------------------------------------------------------------------- package Curses::UI::SearchEntry; use Curses; use Curses::UI::Widget; # For height_by_windowscrheight() use Curses::UI::Common; use Curses::UI::Container; use vars qw( $VERSION @ISA ); $VERSION = "1.10"; @ISA = qw( Curses::UI::ContainerWidget ); sub new() { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -prompt => '/', # The initial search prompt %userargs, -x => 0, -y => -1, -width => undef, -border => 0, -sbborder => 0, -showlines => 0, -focus => 0, ); # The windowscr height should be 1. $args{-height} = height_by_windowscrheight(1,%args); my $this = $class->SUPER::new(%args); my $entry = $this->add( 'entry', 'TextEntry', -x => 1, -y => 0, -height => 1, -border => 0, -sbborder => 0, -showlines => 0, -width => undef, -intellidraw => 0, ); $this->add( 'prompt', 'Label', -x => 0, -y => 0, -height => 1, -width => 2, -border => 0, -text => $this->{-prompt}, -intellidraw => 0, ); $entry->set_routine('loose-focus', \&entry_loose_focus); $this->layout; return $this; } sub entry_loose_focus() { my $this = shift; $this->parent->loose_focus; } sub event_keypress($;) { my $this = shift; my $key = shift; my $entry = $this->getobj('entry'); if ($entry->{-focus}) { $this->getobj('entry')->event_keypress($key); } else { $this->{-key} = $key; } return $this; } sub get() { my $this = shift; $this->getobj('entry')->get; } sub pos(;$) { my $this = shift; my $pos = shift; $this->getobj('entry')->pos($pos); } sub text(;$) { my $this = shift; my $text = shift; $this->getobj('entry')->text($text); } sub prompt(;$) { my $this = shift; my $prompt = shift; if (defined $prompt) { $prompt = substr($prompt, 0, 1); $this->{-prompt} = $prompt; $this->getobj('prompt')->text($prompt); $this->intellidraw; return $this; } else { return $this->{-prompt}; } } # Let Curses::UI->usemodule() believe that this module # was already loaded (usemodule() would else try to # require the non-existing file). # $INC{'Curses/UI/SearchEntry.pm'} = $INC{'Curses/UI/Searchable.pm'}; # ---------------------------------------------------------------------- # Searchable package # ---------------------------------------------------------------------- package Curses::UI::Searchable; use strict; use Curses; use Curses::UI::Common; require Exporter; use vars qw( $VERSION @ISA @EXPORT ); $VERSION = '1.10'; @ISA = qw( Exporter ); @EXPORT = qw( search_forward search_backward search search_next ); sub search_forward() { my $this = shift; $this->search("/", +1); } sub search_backward() { my $this = shift; $this->search("?", -1); } sub search() { my $this = shift; my $prompt = shift || ':'; my $direction = shift || +1; $this->change_canvasheight(-1); $this->draw; my $querybox = new Curses::UI::SearchEntry( -parent => $this, -prompt => $prompt, ); my $old_cursor_mode = $this->root->cursor_mode; $this->root->cursor_mode(1); $querybox->getobj('entry')->{-focus} = 1; $querybox->draw; $querybox->modalfocus(); $querybox->getobj('entry')->{-focus} = 0; my $query = $querybox->get; $querybox->prompt(':'); $querybox->draw; my $key; if ($query ne '') { my ($newidx, $wrapped) = $this->search_next($query, $direction); KEY: for (;;) { unless (defined $newidx) { $querybox->text('Not found'); } else { $querybox->text($wrapped ? 'Wrapped' : ''); } $querybox->pos(0); $querybox->draw; $querybox->{-key} = '-1'; while ($querybox->{-key} eq '-1') { $this->root->do_one_event($querybox); } if ($querybox->{-key} eq 'n') { ($newidx, $wrapped) = $this->search_next($query, $direction); } elsif ($querybox->{-key} eq 'N') { ($newidx, $wrapped) = $this->search_next($query, -$direction); } else { last KEY; } } } # Restore the screen. $this->root->cursor_mode($old_cursor_mode); $this->change_canvasheight(+1); $this->draw; $this->root->feedkey($querybox->{-key}); return $this; } sub search_next($$;) { my $this = shift; my $query = shift; my $direction = shift; $direction = ($direction > 0 ? +1 : -1); $this->search_get($query, $direction); } sub change_canvasheight($;) { my $this = shift; my $change = shift; if ($change < 0) { # Change the canvasheight, so we can fit in the searchline. $this->{-sh}--; $this->{-yscrpos}++ if ($this->{-ypos}-$this->{-yscrpos} == $this->canvasheight); } elsif ($change > 0) { # Restore the canvasheight. $this->{-sh}++; my $inscreen = ($this->canvasheight - ($this->number_of_lines - $this->{-yscrpos})); while ($this->{-yscrpos} > 0 and $inscreen < $this->canvasheight) { $this->{-yscrpos}--; $inscreen = ($this->canvasheight - ($this->number_of_lines - $this->{-yscrpos})); } } $this->{-search_highlight} = undef; $this->layout_content(); } sub search_get($$;) { my $this = shift; my $query = shift; my $direction = shift || +1; my $startpos = $this->{-ypos}; my $offset = 0; my $wrapped = 0; for (;;) { # Find the line position to match. $offset += $direction; my $newpos = $this->{-ypos} + $offset; my $last_idx = $this->number_of_lines - 1; # Beyond limits? if ($newpos < 0) { $newpos = $last_idx; $offset = $newpos - $this->{-ypos}; $wrapped = 1; } if ($newpos > $last_idx) { $newpos = 0; $offset = $newpos - $this->{-ypos}; $wrapped = 1; } # Nothing found? return (undef,undef) if $newpos == $startpos; if ($this->getline_at_ypos($newpos) =~ /\Q$query/i) { $this->{-ypos} = $newpos; $this->{-search_highlight} = $newpos; $startpos = $newpos; $this->layout_content; $this->draw(1); return $newpos, $wrapped; $wrapped = 0; } } } 1; =pod =head1 NAME Curses::UI::Searchable - Add 'less'-like search abilities to a widget =head1 CLASS HIERARCHY Curses::UI::Searchable - base class =head1 SYNOPSIS package MyWidget; use Curses::UI::Searchable; use vars qw(@ISA); @ISA = qw(Curses::UI::Searchable); .... sub new () { # Create class instance $this. .... $this->set_routine('search-forward', \&search_forward); $this->set_binding('search-forward', '/'); $this->set_routine('search-backward', \&search_backward); $this->set_binding('search-backward', '?'); } sub layout_content() { my $this = shift; # Layout your widget's content. .... return $this; } sub number_of_lines() { my $this = shift; # Return the number of lines in # the widget's content. return .... } sub getline_at_ypos($;) { my $this = shift; my $ypos = shift; # Return the content on the line # where ypos = $ypos return .... } =head1 DESCRIPTION Using Curses::UI::Searchable, you can add 'less'-like search capabilities to your widget. To make your widget searchable using this class, your widget should meet the following requirements: =over 4 =item * B All methods for searching are in Curses::UI::Searchable. By making your class a descendant of this class, these methods are automatically inherited. =item * B<-ypos data member> The current vertical position in the widget should be identified by $this->{-ypos}. This y-position is the index of the line of content. Here's an example for a Listbox widget. -ypos | v +------+ 0 |One | 1 |Two | 2 |Three | +------+ =item * B Your widget class should have a method B, which returns the total number of lines in the widget's content. So in the example above, this method would return the value 3. =item * B Your widget class should have a method B, which returns the line of content at -ypos YPOS. So in the example above, this method would return the value "Two" for YPOS = 1. =item * B The search routines will set the -ypos of your widget if a match is found for the given search string. Your B routine should make sure that the line of content at -ypos will be made visible if the B method is called. =item * B If the search routines find a match, $this->{-search_highlight} will be set to the -ypos for the line on which the match was found. If no match was found $this->{-search_highlight} will be undefined. If you want a matching line to be highlighted, in your widget, you can use this data member to do so (an example of a widget that uses this option is the L widget). =item * B There are two search routines. These are B and B. These have to be called in order to display the search prompt. The best way to do this is by creating bindings for them. Here's an example which will make '/' a forward search and '?' a backward search: $this->set_routine('search-forward' , \&search_forward); $this->set_binding('search-forward' , '/'); $this->set_routine('search-backward' , \&search_backward); $this->set_binding('search-backward' , '?'); =back =head1 SEE ALSO L, =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Language/0000755000175000001440000000000011630214052016324 5ustar mdxiusersCurses-UI-0.9609/lib/Curses/UI/Language/polish.pm0000644000175000001440000000433411627564364020210 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::polish # Maintainer: ak@min.pl # ---------------------------------------------------------------------- package Curses::UI::Language::polish; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Rozmiar twojego ekranu jest zbyt may dla tej aplikacji. Zmie rozmiar ekranu i uruchom ponownie aplikacj. Nacinij aby zakoczy... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Stycze Luty Marzec Kwiecie Maj Czerwiec Lipiec Sierpie Wrzesie Padziernik Listopad Grudzie [days_short] Ni Po Wt r Cz Pi So # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] a:Anuluj [button_yes] t:Tak [button_no] n:Nie # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Komunikat o bdzie # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Wybierz plik [file_savetitle] Wybierz plik do zapisu [file_loadtitle] Wybierz plik do odczytu # The labels for the dialog screen. [file_path] cieka : [file_file] Plik : [file_mask] Maska : # The size of the longest label [file_labelsize] 9 # On directory up [file_dirup] Katalog nadrzdny # For asking the user if a file may be overwritten [file_overwrite_title] Potwierdzenie [file_overwrite_question_pre] Plik " [file_overwrite_question_post] " ju istnieje. Czy chcesz zamieni istniejcy plik? # Errors [file_err_opendir_pre] Nie mona otworzy katalogu " [file_err_opendir_post] " [file_err_nofileselected] Nie wybrano pliku! Curses-UI-0.9609/lib/Curses/UI/Language/chinese.pm0000644000175000001440000000424211627564364020326 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::chinese # Maintainer: kongyp@163.com # ---------------------------------------------------------------------- package Curses::UI::Language::chinese; 1; __DATA__ ####################################UI=as below???? # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] ĵǰĻ˵̫С ĻС ˳... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] һ ʮ ʮһ ʮ [days_short] һ ڶ # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o: [button_cancel] c:˳ [button_yes] y: [button_no] n: # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Ϣ # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] ѡһļ [file_savetitle] ѡ񱣴һļ [file_loadtitle] ѡһļ # The dirbrowser title [dir_title] ѡһĿ¼ # The labels for the dialog screen. [file_path] · : [file_file] ļ: [file_mask] : # The size of the longest label [file_labelsize] # On directory up [file_dirup] Ŀ¼ # For asking the user if a file may be overwritten [file_overwrite_title] Confirm [file_overwrite_question_pre] ȷϸļ " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] ܴĿ¼ " [file_err_opendir_post] " [file_err_nofileselected] 㻹ûѡһļ! Curses-UI-0.9609/lib/Curses/UI/Language/dutch.pm0000644000175000001440000000437511627564364020026 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::dutch # Maintainer: maurice@gitaar.net # ---------------------------------------------------------------------- package Curses::UI::Language::dutch; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Uw scherm is momenteel te klein voor deze applicatie. Maak het scherm groter en herstart de applicatie. Druk op om het programma te verlaten... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Januari Februari Maart April Mei Juni Juli Augustus September Oktober November December [days_short] Zo Ma Di Wo Do Vr Za # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] a:Annuleren [button_yes] j:Ja [button_no] n:Nee # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Foutmelding # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Selecteer bestand [file_savetitle] Selecteer bestand om te schrijven [file_loadtitle] Selecteer bestand om te lezen # The labels for the dialog screen. [file_path] Pad : [file_file] Bestand : [file_mask] Masker : # The size of the longest label [file_labelsize] 9 # On directory up [file_dirup] Directory hoger # For asking the user if a file may be overwritten [file_overwrite_title] Bevestiging [file_overwrite_question_pre] Weet u zeker dat u het bestand " [file_overwrite_question_post] " wilt overschrijven? # Errors [file_err_opendir_pre] Kan directory " [file_err_opendir_post] " niet openen [file_err_nofileselected] U heeft nog geen bestand geselecteerd! Curses-UI-0.9609/lib/Curses/UI/Language/turkish.pm0000644000175000001440000000432511627564364020403 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::turkish # Maintainer: suleymanvardar@dsl.ttnet.net.tr # ---------------------------------------------------------------------- package Curses::UI::Language::turkish; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Ekran boyutunuz program iin ok kk. Ekran boyutunuzu bytn ve yeniden balatn. k iin ye basn... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Ocak ubat Mart Nisan Mays Haziran Temmuz Austos Eyll Ekim Kasm Aralk [days_short] Pz Pt Sa a Pe Cu Ct # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:Tamam [button_cancel] c:ptal [button_yes] y:Evet [button_no] n:Hayr # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Hata # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Dosya seiniz [file_savetitle] Kaydedilecek dosyay seiniz [file_loadtitle] Yklenecek dosyay seiniz # The dirbrowser title [dir_title] Klasr seiniz # The labels for the dialog screen. [file_path] Yol : [file_file] Dosya: [file_mask] Maske: # The size of the longest label [file_labelsize] 6 # On directory up [file_dirup] st klasr # For asking the user if a file may be overwritten [file_overwrite_title] Onay [file_overwrite_question_pre] Gerekten zerine yazmak istiyor musunuz " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] Klasre eriilemiyor " [file_err_opendir_post] " [file_err_nofileselected] Bir dosya semediniz! Curses-UI-0.9609/lib/Curses/UI/Language/french.pm0000644000175000001440000000436711627564364020165 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::french # Maintainer: seb@H-K.fr # ---------------------------------------------------------------------- package Curses::UI::Language::french; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Votre fentre est trop petite pour cette application. Veuillez l'agrandir et redmarrer l'application. Appuyez sur pour sortir... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Janvier Fvrier Mars Avril Mai Juin Juillet Aot Septembre Octobre Novembre Dcembre [days_short] Di Lu Ma Me Je Ve Sa # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c:Annuler [button_yes] y:Oui [button_no] n:Non # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Message d'erreur # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Choisissez un fichier [file_savetitle] Choisissez un fichier dans lequel enregistrer [file_loadtitle] Choisissez un fichier charger # The labels for the dialog screen. [file_path] Chemin : [file_file] Fichier : [file_mask] Masque : # The size of the longest label [file_labelsize] 9 # On directory up [file_dirup] Dossier parent # For asking the user if a file may be overwritten [file_overwrite_title] Confirmation [file_overwrite_question_pre] Voulez-vous vraiment craser le fichier " [file_overwrite_question_post] " ? # Errors [file_err_opendir_pre] Impossible d'ouvrir le dossier " [file_err_opendir_post] " [file_err_nofileselected] Vous n'avez pas choisi de fichier ! Curses-UI-0.9609/lib/Curses/UI/Language/portuguese.pm0000644000175000001440000000440011627564364021106 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::portuguese # Maintainer: raul@dias.com.br # ---------------------------------------------------------------------- package Curses::UI::Language::portuguese; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] A sua tela atualmente muito pequena para essa aplicao. Altere o tamanho da tela e reinicie a aplicao. Pressione para sair... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Janeiro Fevereiro Maro Abril Maio Junho Julho Agosto Setembro Outubro Novembro Dezembro [days_short] Do Se Te Qa Qi Se Sa # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c:Cancelar [button_yes] s:Sim [button_no] n:No # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Mensagem de Erro # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Selecione um arquivo [file_savetitle] Selecione um arquivo para salvar [file_loadtitle] Selecione um arquivo para carregar # The labels for the dialog screen. [file_path] Caminho : [file_file] Arquivo : [file_mask] Mascara : # The size of the longest label [file_labelsize] 9 # On directory up [file_dirup] Diretrio Anterior # For asking the user if a file may be overwritten [file_overwrite_title] Confirme [file_overwrite_question_pre] Voc quer realmente sobrescrever esse arquivo " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] No posso abrir o diretrio " [file_err_opendir_post] " [file_err_nofileselected] Voc no selecionou um arquivo! Curses-UI-0.9609/lib/Curses/UI/Language/norwegian.pm0000644000175000001440000000424511627564364020704 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::norwegian # Maintainer: Vlad Tepes (miceme@start.no) # ---------------------------------------------------------------------- package Curses::UI::Language::norwegian; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Your screen is currently too small for this application. Resize the screen and restart the application. Press to exit... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Januar Februar Mars April Mai Juni Juli August September Oktober November Desember [days_short] S Ma Ti On To Fr L # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c:Avbryt [button_yes] y:Ja [button_no] n:Nei # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Feilmelding # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Velg en fil [file_savetitle] Velg filnavn for lagring [file_loadtitle] Velg fil for pning # The labels for the dialog screen. [file_path] Sti : [file_file] Fil : [file_mask] Maske : # The size of the longest label [file_labelsize] 6 # On directory up [file_dirup] Opp ett niv # For asking the user if a file may be overwritten [file_overwrite_title] Bekreft [file_overwrite_question_pre] Er du sikker p at du vil overskrive " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] Kan ikke pne mappen " [file_err_opendir_post] " [file_err_nofileselected] Ingen fil er valgt! Curses-UI-0.9609/lib/Curses/UI/Language/japanese.pm0000644000175000001440000000500711627564364020476 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::japanese # Maintainer: Takatoshi Kitano # ---------------------------------------------------------------------- package Curses::UI::Language::japanese; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] あなたの画面はこのアプリケーションには小さすぎます。 画面をリサイズして、アプリケーションを再起動してください。 終了するためにはを押してください。 # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] 1月 2月 3月 4月 5月 6月 7月 8月 9月 10月 11月 12月 [days_short] 日 月 火 水 木 金 土 # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c:キャンセル [button_yes] y:はい [button_no] n:いいえ # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] エラーメッセージ # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] ファイルを選択する [file_savetitle] 保存先のファイルを選択する [file_loadtitle] ロードするファイルを選択する # The dirbrowser title [dir_title] ディレクトリを選択する # The labels for the dialog screen. [file_path] パス : [file_file] ファイル : [file_mask] マスク : # The size of the longest label [file_labelsize] 6 # On directory up [file_dirup] 親ディレクトリ # For asking the user if a file may be overwritten [file_overwrite_title] 確認 [file_overwrite_question_pre] 本当にこのファイルを上書きしたいですか " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] ディレクトリを開くことができません " [file_err_opendir_post] " [file_err_nofileselected] ファイルを選択していません! Curses-UI-0.9609/lib/Curses/UI/Language/russian.pm0000644000175000001440000000441711627564364020400 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::russian # This file is in KOI8-R encoding # Maintainer: maurice@gitaar.net, cursesui@nslu.x.myxomop.com # ---------------------------------------------------------------------- package Curses::UI::Language::russian; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] . . ^C . # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] [days_short] # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c: [button_yes] y: [button_no] n: # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] [file_savetitle] [file_loadtitle] # The labels for the dialog screen. [file_path] : [file_file] : [file_mask] : # The size of the longest label [file_labelsize] 6 # On directory up [file_dirup] # For asking the user if a file may be overwritten [file_overwrite_title] [file_overwrite_question_pre] " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] " [file_err_opendir_post] " [file_err_nofileselected] ! Curses-UI-0.9609/lib/Curses/UI/Language/slovak.pm0000644000175000001440000000431311627564364020206 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::slovak # Maintainer: marx@linux.sk # ---------------------------------------------------------------------- package Curses::UI::Language::slovak; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Toto okno je prli mal pre tto aplikciu. Okno zvite a aplikciu spustite ete raz. Stlaenm ukonte aplikciu. # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Janur Februr Marec Aprl Mj Jn Jl August September Oktber November December [days_short] Ned Pon Uto Str tv Pia Sob # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c:Zrui [button_yes] y:no [button_no] n:Nie # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Chybov hlsenie # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Zvoli sbor [file_savetitle] Uloi sbor [file_loadtitle] Otvori sbor # The dirbrowser title [dir_title] Zvoli prieinok # The labels for the dialog screen. [file_path] Cesta : [file_file] Sbor : [file_mask] Maska : # The size of the longest label [file_labelsize] 6 # On directory up [file_dirup] Nadraden prieinok # For asking the user if a file may be overwritten [file_overwrite_title] Potvrdi [file_overwrite_question_pre] Prajete si prepsa sbor " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] Nemem otvori prieinok " [file_err_opendir_post] " [file_err_nofileselected] Nezvolili ste sbor! Curses-UI-0.9609/lib/Curses/UI/Language/english.pm0000644000175000001440000000436611627564364020350 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::english # Maintainer: marcus@thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Language::english; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Your screen is currently too small for this application. Resize the screen and restart the application. Press to exit... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] January February March April May June July August September October November December [days_short] Su Mo Tu We Th Fr Sa # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c:Cancel [button_yes] y:Yes [button_no] n:No # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Error message # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Select a file [file_savetitle] Select a file to save to [file_loadtitle] Select a file to load from # The dirbrowser title [dir_title] Select a directory # The labels for the dialog screen. [file_path] Path : [file_file] File : [file_mask] Mask : # The size of the longest label [file_labelsize] 6 # On directory up [file_dirup] Parent directory # For asking the user if a file may be overwritten [file_overwrite_title] Confirm [file_overwrite_question_pre] Do you really want to overwrite the file " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] Can't open directory " [file_err_opendir_post] " [file_err_nofileselected] You have not selected a file! Curses-UI-0.9609/lib/Curses/UI/Language/czech.pm0000644000175000001440000000435611627564364020012 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::czech # Maintainer: Jiri Vaclavik # ---------------------------------------------------------------------- package Curses::UI::Language::czech; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Vase obrazovka je prilis mala pro tuto aplikaci. Zmente velikost obrazovky a aplikaci spustte znovu. Stisknete pro konec... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Leden Unor Brezen Duben Kveten Cerven Cervenec Srpen Zari Rijen Listopad Prosinec [days_short] Ne Po Ut St Ct Pa So # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] c:Zrusit [button_yes] y:Ano [button_no] n:Ne # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Chybova zprava # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Vyber soubor [file_savetitle] Vyber soubor pro ulozeni [file_loadtitle] Vyber soubor pro nacteni # The dirbrowser title [dir_title] Vyber adresar # The labels for the dialog screen. [file_path] Cesta : [file_file] Soubor : [file_mask] Maska : # The size of the longest label [file_labelsize] 8 # On directory up [file_dirup] Rodicovsky adresar # For asking the user if a file may be overwritten [file_overwrite_title] Prepsani [file_overwrite_question_pre] Opravdu chcete prepsat soubor " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] Adresar nelze otevrit! " [file_err_opendir_post] " [file_err_nofileselected] Nevybral jste soubor! Curses-UI-0.9609/lib/Curses/UI/Language/spanish.pm0000644000175000001440000000450611627564364020360 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::spanish # Maintainer: marcus@thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Language::spanish; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Tu pantalla es muy pequea para esta aplicacin. Cambia el tamao de tu pantalla y reinicia la aplicacin. Presiona para salir... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Enero Febrero Marzo Abril Mayo Junio Julio Agosto Septiembre Octubre Noviembre Diciembre [days_short] Do Lu Mar Mie Ju Vi Sa # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:Aceptar [button_cancel] c:Cancelar [button_yes] y:S [button_no] n:No # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Mensaje de Error # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Selecciona un archivo [file_savetitle] Selecciona un archivo a donde grabar [file_loadtitle] Selecciona un archivo de donde cargar # The dirbrowser title [dir_title] Selecciona un directorio # The labels for the dialog screen. [file_path] Ruta : [file_file] Archivo : [file_mask] Mscara : # The size of the longest label [file_labelsize] 6 # On directory up [file_dirup] Directory padre # For asking the user if a file may be overwritten [file_overwrite_title] Confirmar [file_overwrite_question_pre] Realmente quieres sobreescribir el archivo " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] No se puede abrir el directorio " [file_err_opendir_post] " [file_err_nofileselected] No has seleccionado un archivo! Curses-UI-0.9609/lib/Curses/UI/Language/italian.pm0000644000175000001440000000453511627564364020336 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::english # Maintainer: maurice@gitaar.net # ---------------------------------------------------------------------- package Curses::UI::Language::italian; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Il tuo schermo e' troppo piccolo per questa applicazione. Ridimensionalo ed esegui nuovamente l'applicazione. Premi per uscire... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Gennaio Febbraio Marzo Aprile Maggio Giugno Luglio Agosto Settembre Ottobre Novembre Dicembre [days_short] Do Lu Ma Me Gi Ve Sa # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:Conferma [button_cancel] c:Annulla [button_yes] y:Si [button_no] n:No # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Errore # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Seleziona un file [file_savetitle] Seleziona un file da salvare #Select a file to save to [file_loadtitle] Seleziona un file da aprire #Select a file to load from # The dirbrowser title [dir_title] Seleziona una directory # The labels for the dialog screen. [file_path] Percorso : [file_file] File : [file_mask] Maschera : # The size of the longest label [file_labelsize] 10 # On directory up [file_dirup] Cartella Precedente # For asking the user if a file may be overwritten [file_overwrite_title] Conferma [file_overwrite_question_pre] Desideri veramente sovrascrivere il file " [file_overwrite_question_post] "? # Errors [file_err_opendir_pre] Impossible aprire la cartella " [file_err_opendir_post] " [file_err_nofileselected] Nessun file selezionato! Curses-UI-0.9609/lib/Curses/UI/Language/german.pm0000644000175000001440000000437411627564364020167 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language::german # Maintainer: kleine@ak.sax.de # ---------------------------------------------------------------------- package Curses::UI::Language::german; 1; __DATA__ # ---------------------------------------------------------------------- # For Curses::UI # ---------------------------------------------------------------------- [screen_too_small] Die Fenstergröße ist zu klein für dieses Programm. Bitte Größe Ändern und das Programm neu starten. drücken zum Beenden... # ---------------------------------------------------------------------- # For Curses::UI::Calendar # ---------------------------------------------------------------------- [months] Januar Februar März April Mai Juni Juli August September Oktober November Dezember [days_short] Su Mo Di Mi Do Fr Sa # ---------------------------------------------------------------------- # For Curses::UI::Buttonbox # ---------------------------------------------------------------------- [button_ok] o:OK [button_cancel] a:Abbrechen [button_yes] j:Ja [button_no] n:Nein # ---------------------------------------------------------------------- # For Curses::UI::Dialog::Error # ---------------------------------------------------------------------- [error_title] Fehlermeldung # ---------------------------------------------------------------------- # For Curses::UI::Dialog::FileBrowser # ---------------------------------------------------------------------- # The filebrowser title [file_title] Dateiauswahl [file_savetitle] Dateiauswahl zum Speichern [file_loadtitle] Dateiauswahl zum Laden # The dirbrowser title [dir_title] Verzeichnisauswahl # The labels for the dialog screen. [file_path] Pfad : [file_file] Datei : [file_mask] Maske : # The size of the longest label [file_labelsize] 7 # On directory up [file_dirup] Höheres Verzeichnis # For asking the user if a file may be overwritten [file_overwrite_title] Bestätigung [file_overwrite_question_pre] Datei wirklich Überschreiben " [file_overwrite_question_post] " ? # Errors [file_err_opendir_pre] Kann Verzeichnis nicht öffnen " [file_err_opendir_post] " [file_err_nofileselected] Keine Datei ausgewählt! Curses-UI-0.9609/lib/Curses/UI/Container.pm0000644000175000001440000004477711627602216017115 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Container # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: update dox package Curses::UI::Container; use Curses; use Curses::UI::Widget; use Curses::UI::Common; use vars qw( @ISA $VERSION ); $VERSION = "1.11"; @ISA = qw( Curses::UI::Widget Curses::UI::Common ); # ---------------------------------------------------------------------- # Public interface # ---------------------------------------------------------------------- # Create a new Container object. sub new() { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -releasefocus => 0, # Allows the focus to be released to parent on end %userargs, -id2object => undef, # Id to object mapping -object2id => undef, # Object to id mapping -focusorder => [], # The order in which objects get focused -draworder => [], # The order in which objects get drawn -focus => 0, # Value init ); my $this = $class->SUPER::new(%args); } DESTROY() { my $this = shift; $this->SUPER::delete_subwindows(); } # Add an object to the container sub add($@) { my $this = shift; my $id = shift; my $class = shift; my %args = @_; $this->root->fatalerror( "The object id \"$id\" is already in use!" ) if defined $id and defined $this->{-id2object}->{$id}; # If $id is not defined, create an auto-id. if (not defined $id) { my $i = 0; my $id_pre = "__container_auto_id_"; do { $id = $id_pre . $i++ } until (not defined $this->{-id2object}->{$id}); } # Make it possible to specify WidgetType instead of # Curses::UI::WidgetType. $class = "Curses::UI::$class" if $class !~ /\:\:/ or $class =~ /^Dialog\:\:[^\:]+$/; # Create a new object of the wanted class. $this->root->usemodule($class); my $object = $class->new( %args, -parent => $this ); # Store the object. $this->{-id2object}->{$id} = $object; $this->{-object2id}->{$object} = $id; # begin by AGX: inherith parent background color! if (defined( $object->{-bg} )) { if ($object->{-bg} eq "-1" ) { if (defined( $this->{-bg} )) { $object->{-bg} = $this->{-bg}; } } } # end by AGX # begin by AGX: inherith parent foreground color! if (defined( $object->{-fg} )) { if ($object->{-fg} eq "-1" ) { if (defined( $this->{-fg} )) { $object->{-fg} = $this->{-fg}; } } } # end by AGX # Automatically create a focus- and draworder (last added = # last focus/draw). This can be overriden by the # set_focusorder() and set_draworder() functions. push @{$this->{-focusorder}}, $id; unshift @{$this->{-draworder}}, $id; # Return the created object. return $object; } # Delete the contained object with id=$id from the Container. sub delete(;$) { my $this = shift; my $id = shift; return $this unless defined $this->{-id2object}->{$id}; # Delete curses subwindows. $this->{-id2object}->{$id}->delete_subwindows(); # Destroy object. undef $this->{-object2id}->{$this->{-id2object}->{$id}}; delete $this->{-object2id}->{$this->{-id2object}->{$id}}; undef $this->{-id2object}->{$id}; delete $this->{-id2object}->{$id}; foreach my $param (qw(-focusorder -draworder)) { my ($current_focused_id, $new_focused_id, $new_focused_obj); $current_focused_id = $this->{-draworder}->[-1]; my $idx = $this->base_id2idx($param, $id); splice(@{$this->{$param}}, $idx, 1) if defined $idx; #did the deleted id had the focus? if ($current_focused_id eq $id) { $new_focused_id = $this->{-draworder}->[-1]; $new_focused_obj = $this->{-id2object}->{$new_focused_id} if $new_focused_id; $new_focused_obj->event_onfocus if $new_focused_obj; } } return $this; } sub delete_subwindows() { my $this = shift; while (my ($id, $object) = each %{$this->{-id2object}}) { $object->delete_subwindows(); } $this->SUPER::delete_subwindows(); return $this; } # Draw the container and it's contained objects. sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the Widget. $this->SUPER::draw(1) or return $this; # Draw all contained object. foreach my $id (@{$this->{-draworder}}) { $this->{-id2object}->{$id}->draw(1); } # Update the screen unless suppressed. doupdate() unless $no_doupdate; return $this; } sub layout() { my $this = shift; $this->SUPER::layout() or return; $this->layout_contained_objects(); return $this; } sub layout_contained_objects() { my $this = shift; # Layout all contained objects. foreach my $id (@{$this->{-draworder}}) { my $obj = $this->{-id2object}->{$id}; $obj->{-parent} = $this; $obj->layout(); $obj->draw(); } return $this; } # Look if there are objects of a certain kind in the container. sub hasa($;) { my $this = shift; my $class = shift; my $count = 0; while (my ($id,$obj) = each %{$this->{-id2object}}) { $count++ if ref $obj eq $class; } return $count; } sub window_is_ontop($;) { my $this = shift; my $win = shift; # If we have a stack of no windows, return immediately. return undef if @{$this->{-draworder}} == 0; my $topwin = $this->{-draworder}->[-1]; if (ref $win) { $topwin = $this->getobj($topwin) } return $topwin eq $win; } sub event_keypress($;) { my $this = shift; my $key = shift; # Try to run the event on this widget. Return # unless the binding returns 'DELEGATE' which # means that this widget should try to delegate # the event to its contained object which has # the focus. # my $return = $this->process_bindings($key); return $return unless defined $return and $return eq 'DELEGATE'; # Get the current focused object and send the # keypress to it. $obj = $this->getfocusobj; if (defined $obj) { return $obj->event_keypress($key); } else { return 'DELEGATE'; } } sub focus_prev() { my $this = shift; # Return without doing anything if we do not # have a focuslist. return $this unless @{$this->{-focusorder}}; # Find the current focused object id. my $id = $this->{-draworder}->[-1]; # Find the current focusorder index. my $idx = $this->focusorder_id2idx($id); my $circle_flag = 0; # Go to the previous object or wraparound. until ($circle_flag) { $idx--; if ($idx < 0) { $idx = @{$this->{-focusorder}} - 1; $circle_flag = 1; } my $new_obj = $this->getobj($this->{-focusorder}[$idx]); last if (defined $new_obj && $new_obj->focusable); } # Focus the previous object. $this->focus($this->{-focusorder}->[$idx], undef, -1); if ( $circle_flag && $this->{-releasefocus} ) { $this->{-parent}->focus_prev; } } sub focus_next() { my $this = shift; # Return without doing anything if we do not # have a focuslist. return $this unless @{$this->{-focusorder}}; # Find the current focused object id. my $id = $this->{-draworder}->[-1]; # Find the current focusorder index. my $idx = $this->focusorder_id2idx($id); # Go to the next object or wraparound. my $circle_flag = 0; until ($circle_flag) { $idx++; if ($idx >= scalar (@{$this->{-focusorder}}) ) { $idx = 0; $circle_flag = 1; } my $new_obj = $this->getobj($this->{-focusorder}[$idx]); last if (defined $new_obj && $new_obj->focusable); } # Focus the next object. $this->focus($this->{-focusorder}->[$idx], undef, +1); #check if we have to release the focus if ( $circle_flag && $this->{-releasefocus} ) { $this->{-parent}->focus_next; } } sub focus(;$$$) { my $this = shift; my $focus_to = shift; my $forced = shift || 0; my $direction = shift || 1; # The direction in which to look for other objects # if this object is not focusable. $direction = ($direction < 0 ? -1 : 1); # Find the id for a object if the argument # is an object. my $new_id = ref $focus_to ? $this->{-object2id}->{$focus_to} : $focus_to; if ($forced and not defined $new_id) { $new_id = $this->{-draworder}->[-1]; } # Do we need to change the focus inside the container? if (defined $new_id) { # Find the currently focused object. my $cur_id = $this->{-draworder}->[-1]; my $cur_obj = $this->{-id2object}->{$cur_id}; # Find the new focused object. my $new_obj = $this->{-id2object}->{$new_id}; $this->root->fatalerror( "focus(): $this has no element with id='$new_id'" ) unless defined $new_obj; # Can the new object be focused? If not, then # try to find the first next object that can # be focused. unless ($new_obj->focusable) { my $idx = $start_idx = $this->focusorder_id2idx($cur_id); undef $new_obj; undef $new_id; OBJECT: for(;;) { $idx += $direction; $idx = 0 if $idx > @{$this->{-focusorder}}-1; $idx = @{$this->{-focusorder}}-1 if $idx < 0; last if $idx == $start_idx; my $test_id = $this->{-focusorder}->[$idx]; my $test_obj = $this->{-id2object}->{$test_id}; if ($test_obj->focusable) { $new_id = $test_id; $new_obj = $test_obj; last OBJECT } } } # Change the draworder if a focusable objects was found. if ($forced or defined $new_obj and $new_obj ne $cur_obj) { my $idx = $this->draworder_id2idx($new_id); my $move = splice(@{$this->{-draworder}}, $idx, 1); push @{$this->{-draworder}}, $move; unless ($new_obj->{-has_modal_focus}) { $cur_obj->event_onblur; } $new_obj->event_onfocus; } } $this->SUPER::focus(); } sub event_onfocus() { my $this = shift; # Do an onfocus event for this object. $this->SUPER::event_onfocus; # If there is a focused object within this # container and this container is not a # container widget, then send an onfocus event to it. unless ($this->isa('Curses::UI::ContainerWidget')) { my $focused_object = $this->getfocusobj; if (defined $focused_object) { $focused_object->event_onfocus; } } return $this; } sub event_onblur() { my $this = shift; #If the Container loose it focus #the current focused child must be unfocused #get the id my $id = $this->{-draworder}->[-1]; return unless $id; #get the object my $obj = $this->{-id2object}->{$id}; return unless $obj; #draw the widget without the focus $obj->{-focus} = 0; $obj->draw; $this->SUPER::event_onblur(); return $this; } sub set_focusorder(@) { my $this = shift; my @order = @_; $this->{-focusorder} = \@order; return $this; } sub set_draworder(@) { my $this = shift; my @order = @_; $this->{-draworder} = \@order; return $this; } sub getobj($;) { my $this = shift; my $id = shift; return $this->{-id2object}->{$id}; } sub getfocusobj() { my $this = shift; my $id = $this->{-draworder}->[-1]; return (defined $id ? $this->getobj($id) : undef); } # ---------------------------------------------------------------------- # Private functions # ---------------------------------------------------------------------- sub draworder_id2idx($;) {shift()->base_id2idx('-draworder' , shift())} sub focusorder_id2idx($;) {shift()->base_id2idx('-focusorder', shift())} sub base_id2idx($;) { my $this = shift; my $param = shift; my $id = shift; my $idx; my $i = 0; foreach my $win_id (@{$this->{$param}}) { if ($win_id eq $id) { $idx = $i; last; } $i++; } return $idx; } =pod =head1 NAME Curses::UI::Container - Create and manipulate container widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $container = $win->add( 'mycontainer', 'Container' ); $container->add( 'contained', 'SomeWidget', ..... ); $container->focus(); =head1 DESCRIPTION A container provides an easy way of managing multiple widgets in a single "form". A lot of Curses::UI functionality is built around containers. The main class L itself is a container. A L is a container. Some of the widgets are implemented as containers. =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-releasefocus> If this option is set, the widgets inside this Container will be part of the focus ordering of the parent widget. This means that when this Container gets the focus, its first widget will be focused. When the focus leaves the last widget inside the Container it will give the focus back to the parent instead of cycling back to the first widget in this Container. This option is useful to create a sub-class packed with common used widgets, making the reuse easier. =back =head1 METHODS =over 4 =item * B ( ) Create a new instance of the Curses::UI::Container class. =item * B ( ID, CLASS, OPTIONS ) This is the main method for this class. Using this method it is easy to add widgets to the container. The ID is an identifier that you want to use for the added widget. This may be any string you want. If you do not need an ID, you may also us an undefined value. The container will automatically create an ID for you. The CLASS is the class which you want to add to the container. If CLASS does not contain '::' or CLASS matches 'Dialog::...' then 'Curses::UI' will be prepended to it. This way you do not have to specifiy the full class name for widgets that are in the Curses::UI hierarchy. It is not necessary to call "use CLASS" yourself. The B method will call the B method from Curses::UI to automatically load the module. The hash OPTIONS contains the options that you want to pass on to the new instance of CLASS. Example: $container->add( 'myid', # ID 'Label', # CLASS -text => 'Hello, world!', # OPTIONS -x => 10, -y => 5, ); =item * B ( ID ) This method deletes the contained widget with the given ID from the container. =item * B ( CLASS ) This method returns true if the container contains one or more widgets of the class CLASS. =item * B ( ) Layout the Container and all its contained widgets. =item * B ( BOOLEAN ) Draw the Container and all its contained widgets. If BOOLEAN is true, the screen will not update after drawing. By default this argument is false, so the screen will update after drawing the container. =item * B ( ) See L for an explanation of this method. =item * B ( ) If the container contains no widgets, this routine will return immediately. Else the container will get focus. If the container gets focus, one of the contained widgets will get the focus. The returnvalue of this widget determines what has to be done next. Here are the possible cases: * The returnvalue is B As soon as a widget returns this value, the container will loose its focus and return the returnvalue and the last pressed key to the caller. * The returnvalue is B The container will not loose focus and the focus will stay at the same widget of the container. * Any other returnvalue The focus will go to the next widget in the container. =item * B ( ID ) This method returns the object reference of the contained widget with the given ID. =item * B ( ) This method returns the object reference of the contained widget which currently has the focus. =item * B ( IDLIST ) Normally the order in which widgets get focused in a container is determined by the order in which they are added to the container. Use B if you want a different focus order. IDLIST contains a list of id's. =item * B ( IDLIST ) Normally the order in which widgets are drawn in a container is determined by the order in which they are added to the container. Use B if you want a different draw order. IDLIST contains a list of id's. =item * B ( CLASS ) This will load the module for the CLASS. If loading fails, the program will die. =item * B ( CODEREF ) This method can be used to set the B<-onfocus> event handler (see above) after initialization of the widget. =item * B ( CODEREF ) This method can be used to set the B<-onblur> event handler (see above) after initialization of the widget. =back =head1 DEFAULT BINDINGS Since interacting is not handled by the container itself, but by the contained widgets, this class does not have any key bindings. =head1 SEE ALSO L, =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Listbox.pm0000644000175000001440000006407711627602216016612 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Listbox # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # (c) 2003-2005 by Marcus Thiesen. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Listbox; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Widget; use Curses::UI::TextEntry; use Curses::UI::TextViewer; use Curses::UI::Searchable; require Exporter; use vars qw( $VERSION @ISA @EXPORT ); $VERSION = '1.3'; @ISA = qw( Curses::UI::Widget Curses::UI::Common Curses::UI::Searchable Exporter ); @EXPORT = qw( maxlabelwidth ); my %routines = ( 'loose-focus' => \&loose_focus, 'option-select' => \&option_select, 'option-check' => \&option_check, 'option-uncheck' => \&option_uncheck, 'option-next' => \&option_next, 'option-prev' => \&option_prev, 'option-nextpage' => \&option_nextpage, 'option-prevpage' => \&option_prevpage, 'option-first' => \&option_first, 'option-last' => \&option_last, 'search-forward' => \&search_forward, 'search-backward' => \&search_backward, 'mouse-button1' => \&mouse_button1, ); my %bindings = ( KEY_LEFT() => 'loose-focus', "h" => 'loose-focus', CUI_TAB() => 'loose-focus', KEY_BTAB() => 'loose-focus', KEY_ENTER() => 'option-select', KEY_RIGHT() => 'option-select', "l" => 'option-select', CUI_SPACE() => 'option-select', "1" => 'option-check', "y" => 'option-check', "0" => 'option-uncheck', "n" => 'option-uncheck', KEY_DOWN() => 'option-next', "j" => 'option-next', KEY_NPAGE() => 'option-nextpage', KEY_UP() => 'option-prev', "k" => 'option-prev', KEY_PPAGE() => 'option-prevpage', KEY_HOME() => 'option-first', "\cA" => 'option-first', KEY_END() => 'option-last', "\cE" => 'option-last', "/" => 'search-forward', "?" => 'search-backward', ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -values => [], # values to show -labels => {}, # optional labels for the values -active => 0, # the activated value -width => undef, # the width of the listbox -height => undef, # the height of the listbox -x => 0, # the hor. pos. rel. to parent -y => 0, # the vert. pos. rel. to parent -multi => 0, # multiselection possible? -radio => 0, # show radio buttons? Only for ! -multi -selected => undef, # the selected item -wraparound => 0, # wraparound on first/last item -onchange => undef, # onChange event handler -onselchange=> undef, # onSelectionChange event handler -bg => -1, -fg => -1, %userargs, -routines => {%routines}, -bindings => {%bindings}, -yscrpos => 0, # Value init -focus => 0, # Value init -nocursor => 1, # This widget does not use a cursor ); if ($args{-multi}) { $args{-radio} = 0; $args{-selected} = {} unless ref $args{-selected} eq 'HASH'; $args{-ypos} = 0; } else { $args{-ypos} = defined $args{-selected} ? $args{-selected} : 0; } my $this = $class->SUPER::new( %args ); $this->layout_content(); if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding('mouse-button1', BUTTON1_CLICKED()); $this->set_mouse_binding('mouse-button1', BUTTON1_DOUBLE_CLICKED()); } return $this; } sub onChange(;$) { shift()->set_event('-onchange', shift()) } sub onSelectionChange(;$) { shift()->set_event('-onselchange', shift()) }; sub values(;$) { my $this = shift; my $values = shift; if (defined $values && ! ref $values) { $values = [ $values, @_ ]; } if (defined $values and ref $values eq 'ARRAY') { # Clear and go to first item if we get new data $this->clear_selection(); $this->{-values} = $values; $this->option_first() if defined $values; # Make this widget non-focusable if there are # no values in it. $this->focusable(scalar(@{$values})); } return $this->{-values} } sub insert_at() { my $this = shift; my $pos = shift; my $values = shift; # Clear and go to first item if we get new data $this->clear_selection(); if (defined $values ) { if (ref $values eq 'ARRAY') { my @newdata = (splice(@{$this->{-values}},0,$pos - 1), @{$values}, @{$this->{-values}}); $this->{-values} = \@newdata; } else { my @newdata = (splice (@{$this->{-values}},0,$pos - 1), $values, @{$this->{-values}}); $this->{-values} = \@newdata; } } return $this->{-values}; } sub labels(;$) { my $this = shift; my $labels = shift; if (defined $labels and ref $labels eq 'HASH') { $this->{-labels} = $labels; } return $this->{-labels} } sub add_labels(;$) { my $this = shift; my $labels = shift; if (defined $labels and ref $labels eq 'HASH') { map $this->{-labels}->{$_} = $labels->{$_}, keys %{$labels}; } return $this->{-labels} } sub maxlabelwidth(@) { my %args = @_; my $maxwidth = 0; foreach my $value (@{$args{-values}}) { my $label = $value; $label = $args{-labels}->{$value} if defined $args{-labels}->{$value}; $maxwidth = length($label) if length($label) > $maxwidth; } return $maxwidth; } sub layout() { my $this = shift; $this->SUPER::layout() or return; $this->layout_content; # Scroll up if we can and the number of visible lines # is smaller than the number of available lines in the screen. my $inscreen = ($this->canvasheight - ($this->number_of_lines - $this->{-yscrpos})); while ($this->{-yscrpos} > 0 and $inscreen < $this->canvasheight) { $this->{-yscrpos}--; $inscreen = ($this->canvasheight - ($this->number_of_lines - $this->{-yscrpos})); } return $this; } sub layout_content() { my $this = shift; return $this if $Curses::UI::screen_too_small; # Check bounds for -ypos index. $this->{-max_selected} = @{$this->{-values}} - 1; $this->{-ypos} = $this->{-max_selected} if $this->{-ypos} > $this->{-max_selected}; $this->{-ypos} = 0 if $this->{-ypos} < 0; # Scroll down if needed. my $ycur = $this->{-ypos} - $this->{-yscrpos}; if ( $ycur > ($this->canvasheight-1)) { $this->{-yscrpos} = $this->{-ypos} - $this->canvasheight + 1; } # Scroll up if needed. elsif ( $ycur < 0 ) { $this->{-yscrpos} = $this->{-ypos}; } $this->{-vscrolllen} = @{$this->{-values}}; $this->{-vscrollpos} = $this->{-yscrpos}; if ( @{$this->{-values}} <= $this->canvasheight) { undef $this->{-vscrolllen}; } return $this; } sub getlabel($;) { my $this = shift; my $idx = shift || 0; my $value = $this->{-values}->[$idx]; my $label = $value; $label = $this->{-labels}->{$label} if defined $this->{-labels}->{$label}; $label =~ s/\t/ /g; # do not show TABs return $label; } sub get_active_value($;) { my $this = shift; my $id = $this->{-ypos}; my $value = $this->{'-values'}->[$id]; return $value; } sub get_active_id($;) { my $this = shift; return $this->{-ypos};; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the widget $this->SUPER::draw(1) or return $this; $this->layout_content; # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } # No values? if (not @{$this->{-values}}) { $this->{-canvasscr}->attron(A_DIM); $this->{-canvasscr}->addstr(0,0,'- no values -'); $this->{-canvasscr}->attroff(A_DIM); # There are values. Show them! } else { my $start_idx = $this->{-yscrpos}; my $end_idx = $this->{-yscrpos} + $this->canvasheight - 1; $end_idx = $this->{-max_selected} if $end_idx > $this->{-max_selected}; my $y = 0; my $cursor_y = 0; my $cursor_x = 0; for my $i ($start_idx .. $end_idx) { # The label to print. my $label = $this->getlabel($i); # Clear up label. $label =~ s/\n|\r//g; # Needed space for prefix. my $prefix_len = (($this->{-multi} or $this->{-radio}) ? 4 : 0); # Chop length if needed. $label = $this->text_chop($label, ($this->canvaswidth-$prefix_len)); # Show current entry in reverse mode and # save cursor position. if ($this->{-ypos} == $i and $this->{-focus}) { $this->{-canvasscr}->attron(A_REVERSE); $cursor_y = $y; $cursor_x = $this->canvaswidth-1; } # Show selected element bold. if ( ( not $this->{-multi} and defined $this->{-selected} and $this->{-selected} == $i) or ( $this->{-multi} and defined $this->{-selected} and $this->{-selected}->{$i}) ) { $this->{-canvasscr}->attron(A_BOLD); } # Make full line reverse or blank $this->{-canvasscr}->addstr( $y, $prefix_len, " "x($this->canvaswidth-$prefix_len) ); # Show label $this->text_draw($y, $prefix_len, $label); $this->{-canvasscr}->attroff(A_REVERSE); $this->{-canvasscr}->attroff(A_BOLD); # Place a [X] for selected value in multi mode. $this->{-canvasscr}->attron(A_BOLD) if $this->{-focus}; if ($this->{-multi}) { if (defined $this->{-selected} and $this->{-selected}->{$i}) { $this->{-canvasscr}->addstr($y, 0, '[X]'); } else { $this->{-canvasscr}->addstr($y, 0, '[ ]'); } } # Place a for selected value in radio mode. elsif ($this->{-radio}) { if (defined $this->{-selected} and $i == $this->{-selected}) { $this->{-canvasscr}->addstr($y, 0, ''); } else { $this->{-canvasscr}->addstr($y, 0, '< >'); } } $this->{-canvasscr}->attroff(A_BOLD) if $this->{-focus}; $y++; } $cursor_x = 1 if $this->{-multi} or $this->{-radio}; $this->{-canvasscr}->move($cursor_y, $cursor_x); } $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } sub option_last() { my $this = shift; $this->{-ypos} = $this->{-max_selected}; $this->run_event('-onselchange'); $this->schedule_draw(1); return $this; } sub option_nextpage() { my $this = shift; if ($this->{-ypos} >= $this->{-max_selected}) { $this->dobeep; return $this; } if ($this->{-ypos} + $this->canvasheight - 1 >= $this->{-max_selected}) { $this->{-ypos} = $this->{-max_selected}; } else { $this->{-ypos} += $this->canvasheight - 1; } $this->run_event('-onselchange'); $this->schedule_draw(1); return $this; } sub option_prevpage() { my $this = shift; if ($this->{-ypos} <= 0) { $this->dobeep; return $this; } if ($this->{-ypos} - $this->canvasheight - 1 < 0) { $this->{-ypos} = 0; } else { $this->{-ypos} -= $this->canvasheight - 1; } $this->run_event('-onselchange'); $this->schedule_draw(1); return $this; } sub clear_selection() { my $this = shift; if ($this->{-multi}) { my $selection = $this->{-selected}; return unless defined $selection; foreach my $id (keys %$selection) { $selection->{$id} = 0; } } else { $this->{-selected} = undef; } $this->schedule_draw(1); } sub set_selection() { my $this = shift; my $id; foreach $id (@_) { next if $id > @{$this->{-values}}; if ($this->{-multi}) { my $changed = ($this->{-selected}->{$id} ? 0 : 1); $this->{-selected}->{$id} = 1; $this->run_event('-onchange') if $changed; $this->schedule_draw(1); } else { my $changed = (not defined $this->{-selected} or ($this->{-selected} != $id)); $this->{-selected} = $id; $this->run_event('-onchange') if $changed; $this->schedule_draw(1); } } return $this; } sub option_next() { my $this = shift; if ($this->{-ypos} >= $this->{-max_selected}) { if ($this->{-wraparound}) { $this->{-ypos} = 0; } else { $this->dobeep; } } else { $this->{-ypos}++; } $this->layout_content; $this->run_event('-onselchange'); $this->schedule_draw(1); return $this; } sub option_prev() { my $this = shift; if ($this->{-ypos} <= 0) { if ($this->{-wraparound}) { $this->{-ypos} = $this->{-max_selected}; } else { $this->dobeep; } } else { $this->{-ypos}--; } $this->layout_content; $this->run_event('-onselchange'); $this->schedule_draw(1); return $this; } sub option_select() { my $this = shift; if ($this->{-multi}) { $this->{-selected}->{$this->{-ypos}} = !$this->{-selected}->{$this->{-ypos}}; $this->run_event('-onselchange'); $this->run_event('-onchange'); $this->schedule_draw(1); return $this; } else { my $changed = (not defined $this->{-selected} or ($this->{-selected} != $this->{-ypos})); $this->{-selected} = $this->{-ypos}; $this->run_event('-onselchange')if $changed; $this->run_event('-onchange') if $changed; $this->schedule_draw(1); return ($this->{-radio} ? $this : 'LOOSE_FOCUS'); } } sub option_first() { my $this = shift; $this->{-ypos} = 0; $this->run_event('-onselchange'); $this->schedule_draw(1); return $this; } sub option_check() { my $this = shift; if ($this->{-multi}) { my $changed = ($this->{-selected}->{$this->{-ypos}} ? 0 : 1); $this->{-selected}->{$this->{-ypos}} = 1; $this->{-ypos}++; $this->run_event('-onchange') if $changed; $this->schedule_draw(1); return $this; } else { my $changed = (not defined $this->{-selected} or ($this->{-selected} != $this->{-ypos})); $this->{-selected} = $this->{-ypos}; $this->run_event('-onchange') if $changed; $this->schedule_draw(1); return ($this->{-radio} ? $this : undef); } } sub option_uncheck() { my $this = shift; if ($this->{-multi}) { my $changed = ($this->{-selected}->{$this->{-ypos}} ? 1 : 0); $this->{-selected}->{$this->{-ypos}} = 0; $this->run_event('-onchange') if $changed; $this->{-ypos}++; } else { $this->dobeep; } $this->schedule_draw(1); return $this; } sub mouse_button1($$$;) { my $this = shift; my $event = shift; my $x = shift; my $y = shift; return unless $this->{-focusable}; $this->layout_content; unless ($this->{-focus}) { $this->focus; } my $newypos = $this->{-yscrpos} + $y; if (@{$this->{-values}} and $newypos >= 0 and $newypos < @{$this->{-values}}) { $this->{-ypos} = $newypos; $this->do_routine('option-select'); } $this->schedule_draw(1); } sub get() { my $this = shift; return unless defined $this->{-selected}; if ($this->{-multi}) { my @values = (); while (my ($id, $val) = each %{$this->{-selected}}) { next unless $val; push @values, $this->{-values}->[$id]; } return @values; } else { return $this->{-values}->[$this->{-selected}]; } } sub id() { my $this = shift; return unless defined $this->{-selected}; if ($this->{-multi}) { my @values = (); while (my ($id, $val) = each %{$this->{-selected}}) { next unless $val; push @values, $id; } return @values; } else { return $this->{-selected}; } } sub get_selectedlabel() { my $this = shift; my $value = $this->get; return unless defined $value; my $label = $this->{-labels}->{$value}; return (defined $label ? $label : $value); } sub set_color_fg { my $this = shift; $this->{-fg} = shift; $this->intellidraw; } sub set_color_bg { my $this = shift; $this->{-bg} = shift; $this->intellidraw; } # ---------------------------------------------------------------------- # Routines for search support # ---------------------------------------------------------------------- sub number_of_lines() { @{shift()->{-values}} } sub getline_at_ypos($;) { shift()->getlabel(shift()) } 1; =pod =head1 NAME Curses::UI::Listbox - Create and manipulate listbox widgets =head1 CLASS HIERARCHY Curses::UI::Widget Curses::UI::Searchable | +----Curses::UI::Listbox =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $listbox = $win->add( 'mylistbox', 'Listbox', -values => [1, 2, 3], -labels => { 1 => 'One', 2 => 'Two', 3 => 'Three' }, -radio => 1, ); $listbox->focus(); my $selected = $listbox->get(); =head1 DESCRIPTION Curses::UI::Listbox is a widget that can be used to create a couple of different kinds of listboxes. These are: =over 4 =item * B A list of values through which can be browsed. One of these values can be selected. The selected value will be highlighted. This kind of listbox looks somewhat like this: +------+ |One | |Two | |Three | +------+ =item * B This is also a list of values, but now more than one value can be selected at once. This kind of listbox looks somewhat like this: +----------+ |[X] One | |[ ] Two | |[X] Three | +----------+ =item * B This looks a lot like the default listbox (only one value can be selected), but now there is clear visual feedback on which value is selected. Before each value "< >" is printed. If a value is selected, "" is printed instead. This kind of listbox looks somewhat like this: +----------+ |< > One | | Two | |< > Three | +----------+ =item * B The listbox supports a primitive markup language to emphasize entries: reverse text bold text underlined text blinking text dim text By using this markup tokens in the values array, you can make the listbox draw the text in the according way. To enable the parser, you have to create the listbox with the -htmltext option. =back =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-values> < ARRAYREF > This option sets the values to use. Unless a label is set for the value (see B<-labels>), this value will be shown in the list. =item * B<-labels> < HASHREF > The keys of this hash reference correspond to the values of the listbox (see B<-values>). The values of the hash are the labels to show in the listbox. It's not obligatory to have a label defined for each value. You may even omit -labels completely. =item * B<-selected> < INDEX > In case the B<-multi> option is not set, INDEX is the index of the value that should be selected. In case the B<-multi> option is set, INDEX is a hash reference in which the keys are the indices of the B<-values> which are selected and the values are any true value. =item * B<-multi> < BOOLEAN > If BOOLEAN has a true value, the listbox will be a multi-select listbox (see DESCRIPTION). =item * B<-radio> < BOOLEAN > If BOOLEAN has a true value, the listbox will be a radiobutton listbox (see DESCRIPTION). =item * B<-wraparound> < BOOLEAN > If BOOLEAN has a true value, wraparound is enabled. This means that if the listbox is on its last value and a key is pressed to go to the next value, the first value will be selected. Also the last value will be selected if this first value is selected and "goto previous value" is pressed. =item * B<-onchange> < CODEREF > This sets the onChange event handler for the listbox widget. If a new item is selected, the code in CODEREF will be executed. It will get the widget reference as its argument. =item * B<-onselchange> < CODEREF > This sets the onSelectionChange event handler for the listbox widget. If a new item is marked as active CODEREF will be executed. It will get the widget reference as its argument. =item * B<-htmltext> < BOOLEAN > Make the Listbox parse primitive markup to change the items appearance. See above. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the values of the currently selected items in the list. If the listbox is not a multi-select listbox only one value will be returned of course. =item * B ( ) This method will return the index of the currently selected items in the list. If the listboy is not a multi-select listbox it will only return one value. =item * B ( ) This method will return the value of the currently active (i.e highlighted line). =item * B ( ) This method will return the index of the currently active (i.e highlighted line). =item * B ( LIST ) This method marks the items at the positions specified in LIST as selected. In a multi-select listbox you can set multiple items with giving multiple values, in a single-select listbox only the last item in LIST will be selected =item * B ( ) This method clears the selected objects of a multi and radiobutton listbox. =item * B ( ARRAYREF ) This method sets the values to use. =item * B < POS, ARRAYREF|SCALAR > This method adds ARRAYREF or SCALAR into the list of values at pos. =item * B [ HASHREF ] This method sets the labels to use. =item * B [ HASHREF ] This method adds the given labels to the already defined ones. =item * B ( CODEREF ) This method can be used to set the B<-onchange> event handler (see above) after initialization of the listbox. =item * B ( CODEREF ) This method can be used to set the B<-onselchange> event handler (see above) after initialization of the listbox. =back =head1 DEFAULT BINDINGS =over 4 =item * >, >, > Call the 'loose-focus' routine. This will have the widget loose its focus. =item * , >, >, > Call the 'option-select' routine. This will select the active item in the listbox. =item * >, > Call the 'option-check' routine. If the listbox is a multi-select listbox, the active item will become checked and the next item will become active. =item * >, > Call the 'option-uncheck' routine. If the listbox is a multi-select listbox, the active item will become unchecked and the next item will become active. =item * >, > Call the 'option-next' routine. This will make the next item of the list active. =item * >, > Call the 'option-prev' routine. This will make the previous item of the list active. =item * > Call the 'option-prevpage' routine. This will make the item on the previous page active. =item * > Call the 'option-nextpage' routine. This will make the item on the next page active. =item * >, > Call the 'option-first' routine. This will make the first item of the list active. =item * >, > Call the 'option-last' routine. This will make the last item of the list active. =item * > Call the 'search-forward' routine. This will make a 'less'-like search system appear in the listbox. A searchstring can be entered. After that the user can search for the next occurance using the 'n' key or the previous occurance using the 'N' key. =item * > Call the 'search-backward' routine. This will do the same as the 'search-forward' routine, only it will search in the opposite direction. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Menubar.pm0000644000175000001440000005301311627564365016557 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Menubar # Curses::UI::MenuListbox # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox # ---------------------------------------------------------------------- # MenuListbox package # ---------------------------------------------------------------------- package Curses::UI::MenuListbox; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Container; use Curses::UI::Window; use Curses::UI::Listbox; use Curses::UI::Widget; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Listbox Curses::UI::Common Curses::UI::Window ); sub new() { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -menu => {}, # The menu contents -is_topmenu => 0, # First pulldown or not? -menubar => undef, # Ref to menubar object -prevobject => undef, # Ref to "parent" object (the real parent # is the rootwindow, but we need to know # which menulistbox or menubar is parent). -bg => -1, -fg => -1, -bbg => -1, -bfg => -1, %userargs, -vscrollbar => 1, # Always use a vscrollbar -border => 1, # Always show a border -wraparound => 1, # Use listbox wraparound -returnaction => undef, # Is set by other MenuListboxes ); # First determine the longest label. my $longest = 0; foreach my $item (@{$args{-menu}}) { my $l = $item->{-label}; $args{-parent}->root->fatalerror( "Missing argument: -label for the MenuListbox" ) unless defined $l; $longest = length($l) if length($l) > $longest; } # Increase $longest for some whitespace on the # right side of the labels. $longest++; # Now create the values and labels for the listbox. my @values = (); my %labels = (); my $has_submenu = 0; foreach my $item (@{$args{-menu}}) { my $l = $item->{-label}; if (defined($item->{-submenu})) { $l = sprintf("%-${longest}s >>", $l); $has_submenu++; } push @values, $l; } # If there are submenu's, make the $longest variable higher. $longest += 4 if $has_submenu; $args{-values} = \@values; # Determine the needed width and hight for the listbox. my $w = width_by_windowscrwidth($longest, %args); my $h = height_by_windowscrheight(@values, %args); $args{-width} = $w; $args{-height} = $h; # Check if the menu does fit on the right. If not, try to # shift it to the left as far as needed. if ($args{-x} + $w > $ENV{COLS}) { $args{-x} = $ENV{COLS} - $w; $args{-x} = 0 if $args{-x} < 0; } my $this = $class->SUPER::new(%args); $this->root->fatalerror( "Missing or illegal argument: -menubar" ) unless defined $args{-menubar} and $args{-menubar}->isa('Curses::UI::Menubar'); # Clear 'loose-focus' binding, so loosing focus through # the key does not work. $this->clear_binding('loose-focus'); # Create binding routines. $this->set_routine('cursor-left', \&cursor_left); $this->set_routine('cursor-right', \&cursor_right); $this->set_routine('option-select',\&option_select); $this->set_routine('escape', \&escape_key); # Create bindings. $this->set_binding('escape', CUI_ESCAPE); $this->set_binding('cursor-left', KEY_LEFT(), 'h'); $this->set_binding('cursor-right', KEY_RIGHT(), 'l'); if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding(\&mouse_button1, BUTTON1_CLICKED()); } return $this; } sub escape_key() { my $this = shift; $this->{-prevobject}->{-returnaction} = 'COLLAPSE'; $this->loose_focus; } sub active_item() { my $this = shift; $this->{-menu}->[$this->{-ypos}]; } sub cursor_left() { my $this = shift; $this->{-prevobject}->{-returnaction} = 'CURSOR_LEFT'; $this->loose_focus; } sub cursor_right() { my $this = shift; # Get the current menu-item. my $item = $this->active_item; # This item has a submenu. Open it. if (defined $item->{-submenu}) { # Compute the (x,y)-position of the new menu. my $x = $this->{-x} + $this->borderwidth; my $y = $this->{-y} + $this->{-ypos}; # Create the submenu. my $id = "__submenu_$this"; my $submenu = $this->root->add( $id, 'MenuListbox', -prevobject => $this, -menubar => $this->{-menubar}, -x => $x, -y => $y, -menu => $this->{-menu}->[$this->{-ypos}]->{-submenu}, -bg => $this->{-bg}, -fg => $this->{-fg}, -bbg => $this->{-bbg}, -bfg => $this->{-bfg}, ); # Show the submenu and wait for it to return. $this->{-returnaction} = undef; $submenu->modalfocus; $this->root->delete($id); $this->root->draw; # Data set by the previous modal focused menulistbox. my $return = $this->{-returnaction}; my $event = $this->{-mouse_event}; if (defined $return) { # COLLAPSE:. Collapse further, unless # $this = . if ($return =~ /^COLLAPSE\:?(.*)$/) { if ($this ne $1) { $this->{-prevobject}->{-returnaction} = $return; $this->{-prevobject}->{-mouse_event} = $event; return $this->loose_focus; } else { $this->focus; return $this->event_mouse($event); } } elsif ($return eq 'COLLAPSE') { return $this->escape_key; } } # This item has no submenu. Return CURSOR_RIGHT # if this is a topmenu. } elsif ($this->{-is_topmenu}) { $this->{-prevobject}->{-returnaction} = 'CURSOR_RIGHT'; $this->loose_focus; } return $this; } sub option_select() { my $this = shift; # Get the current menu-item. my $item = $this->active_item; # Submenu selected? Then expand it. if (defined $item->{-submenu}) { return $this->cursor_right; } # Let the menubar handle the option that was chosen. my $value = $item->{-value}; $this->{-menubar}->menuoption_selected($value); # Let the complete menulistbox-hierarchy collapse. $this->{-prevobject}->{-returnaction} = 'COLLAPSE'; $this->loose_focus; return $this; } sub mouse_button1() { my $this = shift; my $event = shift; my $x = shift; my $y = shift; # First check if the click is inside the widget (since # this widget has modal focus, all events go to it). my $ev_x = $event->{-x}; my $ev_y = $event->{-y}; my $tree = $this->root->object_at_xy($this->root, $ev_x, $ev_y); # Another object is clicked... Collapse the menu. # If a menu-object was clicked, stay on that object # and rerun the event. if ($this ne $tree->[-1]) { $this->{-prevobject}->{-returnaction} = 'COLLAPSE:' . $tree->[-1]; $this->{-prevobject}->{-mouse_event} = $event; $this->loose_focus; return $this; } # Select listbox entry. $this->{-ypos} = $this->{-active} = $this->{-yscrpos} + $y; $this->layout_content(); $this->schedule_draw(1); $this->option_select(); } # Let Curses::UI->usemodule() believe that this module # was already loaded (usemodule() would else try to # require the non-existing file). # $INC{'Curses/UI/MenuListbox.pm'} = $INC{'Curses/UI/Menubar.pm'}; # ---------------------------------------------------------------------- # Menubar package # ---------------------------------------------------------------------- package Curses::UI::Menubar; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Container; use Curses::UI::Window; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Window Curses::UI::Common ); my %routines = ( 'escape' => \&escape, 'pulldown' => \&pulldown, 'menu-left' => \&menu_left, 'menu-right' => \&menu_right, 'mouse-button1' => \&mouse_button1, ); my %bindings = ( KEY_DOWN() => 'pulldown', 'j' => 'pulldown', KEY_ENTER() => 'pulldown', KEY_LEFT() => 'menu-left', 'h' => 'menu-left', KEY_RIGHT() => 'menu-right', 'l' => 'menu-right', CUI_ESCAPE() => 'escape', ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -parent => undef, # the parent window -menu => [], # the menu definition -menuhandler => undef, # a custom menu handler (optional) -bg => -1, -fg => -1, %userargs, -routines => {%routines}, -bindings => {%bindings}, -width => undef, # Always use the full width -height => 1, # Always use height = 1 -focus => 0, -nocursor => 1, # This widget does not use a cursor -x => 0, -y => 0, -border => 0, -selected => 0, -returnaction => undef, # is set by MenuListboxes. -menuoption => undef, # the value for the chosen option # (is also set by MenuListboxes). -is_expanded => 0, # let show focused on expand ); my $this = $class->SUPER::new( %args ); $this->layout; if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding('mouse-button1', BUTTON1_CLICKED()); } return $this; } sub escape() { my $this = shift; $this->loose_focus; } sub layout() { my $this = shift; $this->SUPER::layout or return; return $this; } sub draw() { my $this = shift; my $no_doupdate = shift || 0; $this->SUPER::draw(1) or return $this; # Create full reverse menubar. $this->{-canvasscr}->attron(A_REVERSE); # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-bg}, $this->{-fg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } $this->{-canvasscr}->addstr(0, 0, " "x$this->canvaswidth); # Create menu-items. my $x = 1; my $idx = 0; foreach my $item (@{$this->{-menu}}) { # By default the bar is drawn in reverse. $this->{-canvasscr}->attron(A_REVERSE); # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-bg}, $this->{-fg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } # If the bar has focus, the selected item is # show without reverse. if ($this->{-focus} and $idx == $this->{-selected}) { $this->{-canvasscr}->attroff(A_REVERSE); } my $label = $item->{-label}; $this->{-canvasscr}->addstr(0, $x, " " . $item->{-label} . " "); $x += length($label) + 2; $idx++; } $this->{-canvasscr}->attroff(A_REVERSE); $this->{-canvasscr}->move(0,0); $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } # This calls the default event_onfocus() routine of # the Widget class and it resets the -menuoption # data member if the menu is not expanded (this will # contain the chosen menuoption at the time the # menubar loses focus). # sub event_onfocus() { my $this = shift; unless ($this->{-is_expanded}) { $this->{-menuoption} = undef; $this->{-selected} = 0; } $this->SUPER::event_onfocus; } sub loose_focus() { my $this = shift; # Draw the menubar like it does not have the focus anymore. $this->{-focus} = 0; $this->draw; # Execute callback routine if a menuitem was selected. my $value = $this->{-menuoption}; if (defined $value) { # Run the make-your-own-handler handler if defined. if (defined $this->{-menuhandler}) { $this->{-menuhandler}->($this, $value); } # Default handler: If $value has CODE in it, run this code. elsif (defined $value and ref $value eq 'CODE') { $value->($this); } } # Focus shifted to another object? Then leave it that way. if ($this->root->focus_path(-1) ne $this) { return $this; } # Else go back to the previous focused window. else { $this->{-focus} = 0; my $prev = $this->root->{-draworder}->[-2]; if (defined $prev) { $this->root->focus($prev); } } } # This calls the default event_onblur() routine of the # Widget class, but if -is_expanded is set, the widget # will still render as a focused widget (this is to # let the selected menuoption show focused, even if # the focus is set to a menulistbox). # sub event_onblur() { my $this = shift; $this->SUPER::event_onblur; if ($this->{-is_expanded}) { $this->{-focus} = 1; } return $this; } sub menuoption_selected() { my $this = shift; my $value = shift; $this->{-menuoption} = $value; } sub pulldown() { my $this = shift; # Find the x position of the selected menu. my $x = 1; my $y = 1; # am I in a window if ($this->{-parent}->{-x}) { $x += $this->{-parent}->{-x}; } # does it have a border if ($this->{-parent}->{-border}) { $x += 1; } # find real x value for my $idx (1 .. $this->{-selected}) { $x += length($this->{-menu}->[$idx-1]->{-label}); $x += 2; } # same for y if ($this->{-parent}->{-y}) { $y += $this->{-parent}->{-y}; } # does it have a border if ($this->{-parent}->{-border}) { $y += 1; } # Add the submenu. my $id = "__submenu_$this"; my $submenu = $this->root->add( $id, 'MenuListbox', -x => $x, -y => $y, -is_topmenu => 1, -menu => $this->{-menu}->[$this->{-selected}]->{-submenu}, -menubar => $this, -prevobject => $this, -fg => $this->{-fg}, -bg => $this->{-bg}, -bfg => $this->{-fg}, -bbg => $this->{-bg}, ); # Focus the new window and wait until it returns. $this->{-returnaction} = undef; $this->{-is_expanded} = 1; $submenu->modalfocus; # Remove the submenu. $this->root->delete($id); $this->root->draw; $this->{-is_expanded} = 0; # Parameters that are set by the previous modal focused menulistbox. my $return = $this->{-returnaction}; my $event = $this->{-mouse_event}; if (defined $return) { # COLLAPSE:. Collapse further, unless # $this = . if ($return =~ /^COLLAPSE\:?(.*)$/) { if ($this ne $1) { $this->{-prevobject}->{-returnaction} = $return; $this->{-prevobject}->{-mouse_event} = $event; return $this->loose_focus; } else { $this->focus; return $this->event_mouse($event); } } elsif ($return eq 'COLLAPSE') { return $this->loose_focus; } elsif ($return eq 'CURSOR_LEFT') { $this->menu_left; $this->focus; $this->draw; $this->root->feedkey(KEY_DOWN()); } elsif ($return eq 'CURSOR_RIGHT') { $this->menu_right; $this->focus; $this->draw; $this->root->feedkey(KEY_DOWN()); } } return $return; } sub menu_left() { my $this = shift; $this->{-selected}--; $this->{-selected} = @{$this->{-menu}}-1 if $this->{-selected} < 0; $this->schedule_draw(1); return $this; } sub menu_right() { my $this = shift; $this->{-selected}++; $this->{-selected} = 0 if $this->{-selected} > (@{$this->{-menu}}-1); $this->schedule_draw(1); return $this; } sub mouse_button1 { my $this = shift; my $MEVENT = shift; my $x = shift; my $y = shift; my $mx = 1; my $idx = 0; foreach my $item (@{$this->{-menu}}) { $mx += length($item->{-label}) + 2; if ($mx > $x) { last } $idx++; } if ($idx > (@{$this->{-menu}}-1)) {$idx--} $this->focus(); $this->{-selected} = $idx; $this->pulldown(); $this->schedule_draw(1); return $this; } 1; =pod =head1 NAME Curses::UI::Menubar - Create and manipulate menubar widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Menubar =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; # define the menu datastructure. my $menu_data = [....]; my $menu = $cui->add( 'menu', 'Menubar', -menu => $menu_data ); $menu->focus(); =head1 DESCRIPTION This class can be used to add a menubar to Curses::UI. This menubar can contain a complete submenu hierarchy. It looks (remotely :-) like this: ------------------------------------- menu1 | menu2 | menu3 | .... ------------------------------------- +-------------+ |menuitem 1 | |menuitem 2 |+--------------+ |menuitem 3 >>||submenuitem 1 | |menuitem 4 ||submenuitem 2 | +-------------+|submenuitem 3 | |submenuitem 4 | |submenuitem 5 | +--------------+ See exampes/demo-Curses::UI::Menubar in the distribution for a short demo. =head1 STANDARD OPTIONS This class does not use any of the standard options that are provided by L. =head1 WIDGET-SPECIFIC OPTIONS There is only one option: B<-menu>. The value for this option is an ARRAYREF. This ARRAYREF behaves exactly like the one that is described in L. The difference is that for the top-level menu, you will only use -submenu's. Example data structure: my $menu1 = [ { -label => 'option 1', -value => '1-1' }, { -label => 'option 2', -value => '1-2' }, { -label => 'option 3', -value => '1-3' }, ]; my $menu2 = [ { -label => 'option 1', -value => \&sel1 }, { -label => 'option 2', -value => \&sel2 }, { -label => 'option 3', -value => \&sel3 }, ]; my $submenu = [ { -label => 'suboption 1', -value => '3-3-1' }, { -label => 'suboption 2', -callback=> \&do_it }, ]; my $menu3 = [ { -label => 'option 1', -value => \&sel2 }, { -label => 'option 2', -value => \&sel3 }, { -label => 'submenu 1', -submenu => $submenu }, ]; my $menu = [ { -label => 'menu 1', -submenu => $menu1 }, { -label => 'menu 2', -submenu => $menu2 } { -label => 'menu 3', -submenu => $menu3 } ]; =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) These are standard methods. See L for an explanation of these. =back =head1 DEFAULT BINDINGS =over 4 =item * > Call the 'escape' routine. This will have the menubar loose its focus and return the value 'ESCAPE' to the calling routine. =item * > Call the 'return' routine. This will have the menubar loose its focus and return the value 'LOOSE_FOCUS' to the calling routine. =item * >, >, > Call the 'pulldown' routine. This will open the menulistbox for the current menu and give that menulistbox the focus. What happens after the menulistbox loses its focus, depends upon the returnvalue of it: * the value 'CURSOR_LEFT' Call the 'cursor-left' routine and after that call the 'pulldown' routine. So this will open the menulistbox for the previous menu. * the value 'CURSOR_RIGHT' Call the 'cursor-right' routine and after that call the 'pulldown' routine. So this will open the menulistbox for the next menu. * the value 'LOOSE_FOCUS' The menubar will keep the focus, but no menulistbox will be open. * the value 'ESCAPE' The menubar will loose its focus and return the value 'ESCAPE' to the calling routine. * A CODE reference The code will be excuted, the menubar will loose its focus and the returnvalue of the CODE will be returned to the calling routine. * Any other value The menubar will loose its focus and the value will be returned to the calling routine. =item * >, > Call the 'cursor-left' routine. This will select the previous menu. If the first menu is already selected, the last menu will be selected. =item * >, > Call the 'cursor-right' routine. This will select the next menu. If the last menu is already selected, the first menu will be selected. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Color.pm0000644000175000001440000001270711627564365016251 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Color # # (c) 2003 by Marcus Thiesen. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Color; use Curses; use Curses::UI::Common; use strict; use vars qw( @ISA $VERSION ); $VERSION = "0.01"; @ISA = qw( Curses::UI::Common ); sub new { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -default_colors => 1, %userargs, ); if ( $args{-default_colors} ) { use_default_colors(); } start_color(); my $this = bless { %args }, $class; $this->{cmap} = { black => COLOR_BLACK, red => COLOR_RED, green => COLOR_GREEN, yellow => COLOR_YELLOW, blue => COLOR_BLUE, magenta => COLOR_MAGENTA, cyan => COLOR_CYAN, white => COLOR_WHITE, }; $this->{pmap} = {}; $this->{pcount} = 0; $this->{ccount} = 7; return $this; } sub get_color_pair { my $this = shift; my $fg = shift; my $bg = shift; return unless defined $fg; return unless defined $bg; my $fgn = $this->{cmap}->{"$fg"}; my $bgn = $this->{cmap}->{"$bg"}; $fgn = -1 unless defined $fgn; $bgn = -1 unless defined $bgn; if ($this->{pmap}->{"$fg.$bg"}) { return $this->{pmap}->{"$fg.$bg"}; } else { $this->{pcount}++; init_pair($this->{pcount}, $fgn, $bgn); $this->{pmap}->{"$fg.$bg"} = $this->{pcount}; return $this->{pcount}; } } sub get_colors { my $this = shift; return keys %{$this->{cmap}}; } sub colors { return $Curses::UI::color_support; } sub define_color { my $this = shift; my $name = shift; my ($r, $g, $b) = @_; return unless $r < 1000; return unless $g < 1000; return unless $b < 1000; return unless $r > 0; return unless $g > 0; return unless $b > 0; init_color($this->{ccount}, $r, $g, $b); $this->{cmap}->{$name} = $this->{ccount}; $this->{ccount}++; return 1; } 1; =pod =head1 NAME Curses::UI::Color - Color support module =head1 WARNING This is a development version. As I do not expect to change the interface during this time it may happen that the color behaviour (e.g. to what extend color is drawn in a window) may change or even the colors themselves. If you want something stable, use -color_support => 0 , but you won't get those fency colors then :-) =head1 DESCRIPTION This module provides all functions related to color support in Curses::UI. The color support was implemented without disturbing old applications, they will look as they used to do. Only if you enable color support explicitly and it is available on your terminal the color functions will have an effect. =head1 SYNOPSIS my $cui = new Curses::UI(-color_support => 1, -clear_on_exit => 0); my $mainw = $cui->add('screen', 'Window'); $mainw->add('l','Label', -bg => "white", -fg => "blue", -text => "Colored Label"); =head1 METHODS =over 4 =item * B (-default-colors => BOOLEAN) Creates a new Curses::UI::Color object, the option default colors define if the use_default_colors function of Curses is used. See L for that. =item * B ( ) Returns all in this object defined colors as an array =item * B ( ) Is true if color support is enabled. =item * B ( NAME, R, G, B ) This function defines a new color in the Color object. The RGB values can be between 0 and 1000. Existing colors can be redefined. =back =head1 USAGE Curses::UI has 7 predefined colors: black red green yellow blue magenta cyan white Curses::UI with color support also defines some new options: -fg -bg for general foreground and background color. -tfg -tbg for widget title fg and bg color -bfg -bbg for widget border fg and bg color -sfg -sbg for scrollbar fg and bg color Every widget has has a runtime setter: set_color_fg ( COLOR ) set_colof_bg ( COLOR ) set_color_tfg ( COLOR ) set_colof_tbg ( COLOR ) set_color_bfg ( COLOR ) set_colof_bbg ( COLOR ) set_color_sfg ( COLOR ) set_colof_sbg ( COLOR ) Mostly every widget has a -fg and -bg option to set the foreground and background color using the above color names. Own colors can be defined using the B method. Every widget that supports color by now has also two functions B and B to set or change the color at runtime. Widgets with borders and scrollbars can use -bfg and -bbg to set the foreground and background color of the border or the -sfg and -sbg option to set the colors of the scrollbar. Widgets with titles can set the -tfg and -tbg option to define the title foreground and background color. Check also the examples/color_editor for seeing what is possible at the moment. =head1 SEE ALSO L =head1 AUTHOR Copyright (c) 2003 Marcus Thiesen. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/0000755000175000001440000000000011630214052016000 5ustar mdxiusersCurses-UI-0.9609/lib/Curses/UI/Dialog/Question.pm0000644000175000001440000002072511627564365020200 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Question # # (c) 2001-2002 by Luke Closs. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # This was mostly copied from Curses::UI::Dialog::Basic # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Question; use strict; use Curses qw(KEY_ENTER); use Curses::UI::Common; use Curses::UI::Window; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Window Curses::UI::Common ); $VERSION = '1.00'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -border => 1, -question => '', # The question to show -answer => '', # a default answer -ipad => 1, -fg => -1, -bg => -1, %userargs, -titleinverse => 1, -centered => 1, ); # Create a new object, but remember the current # screen_too_small setting. The width needed for the # buttons can only be computed in the second run # of focus() and we do not want the first run to # set screen_too_small to a true value because # of this. # my $remember = $Curses::UI::screen_too_small; my $this = $class->SUPER::new(%args); my $q = $this->add('question', 'TextViewer', -x => 1, -y => 0, -wrapping => 1, -padbottom => 0, -height => 3, -text => $this->{-question}, -bg => $this->{-bg}, -fg => $this->{-fg}, -bbg => $this->{-bg}, -bfg => $this->{-fg}, -focusable => 0, ); my $a = $this->add('answer', 'TextEntry', -x => 1, -y => 3, -border => 1, -bg => $this->{-bg}, -fg => $this->{-fg}, -bbg => $this->{-bg}, -bfg => $this->{-fg}, -text => $this->{-answer}); # Push the cursor to the end of the line. $a->{-pos} = 999; # Create a hash with arguments that may be passed to # the Buttonbox class. my %buttonargs = ( -buttonalignment => 'right', ); foreach my $arg (qw(-buttons -selected -buttonalignment)) { $buttonargs{$arg} = $this->{$arg} if exists $this->{$arg}; } my $b = $this->add( 'buttons', 'Buttonbox', -y => -1, -bg => $this->{-bg}, -fg => $this->{-fg}, -buttons => [ 'ok', 'cancel' ], %buttonargs ); # Let the window in which the buttons are loose focus # if a button is pressed, or if enter is hit in the answer box. my $pressed = sub { my $this = shift; my $parent = $this->parent; $parent->{-cancelled} = !$this->get; $parent->loose_focus(); }; $b->set_routine( 'press-button', $pressed ); $a->set_binding( $pressed, KEY_ENTER()); # Restore screen_too_small (see above) and # start the second layout pass. $Curses::UI::screen_too_small = $remember; $this->layout; # Set the initial focus to the answer box. $a->focus; return bless $this, $class; } # TODO delete_curses_windows sub layout() { my $this = shift; return $this if $Curses::UI::screen_too_small; # The maximum available space on the screen. my $avail_width = $ENV{COLS}; my $avail_height = $ENV{LINES}; # Compute the maximum available space for the message. $this->process_padding; my $avail_textwidth = $avail_width; $avail_textwidth -= 2; # border for the textviewer $avail_textwidth -= 2 if $this->{-border}; $avail_textwidth -= $this->{-ipadleft} - $this->{-ipadright}; my $avail_textheight = $avail_height; $avail_textheight -= 2; # border for the textviewer $avail_textheight -= 3; # for answer box $avail_textheight -= 2; # empty line and line of buttons $avail_textheight -= 2 if $this->{-border}; $avail_textheight -= $this->{-ipadtop} - $this->{-ipadbottom}; # Break up the message in separate lines if neccessary. my @lines = (); foreach (split (/\n/, $this->{-question})) { push @lines, @{text_wrap($_, $avail_textwidth)}; } # Compute the longest line in the message. my $longest_line = 0; foreach (@lines) { $longest_line = length($_) if (length($_) > $longest_line); } # Compute the width of the buttons (if the buttons # object is available. This is not the case just after # new() calls SUPER::new()). my $buttons = $this->getobj('buttons'); my $button_width = 0; if (defined $buttons) { $button_width = $buttons->compute_buttonwidth; } # Decide what is the longest line. $longest_line = $button_width if $longest_line < $button_width; # Check if there is enough space to show the widget. if ($avail_textheight < 1 or $avail_textwidth < $longest_line) { $Curses::UI::screen_too_small = 1; return $this; } # Compute the size of the widget. my $w = $longest_line; $w += 2; # border of textviewer $w += 2; # extra width for preventing wrapping of text $w += 2 if $this->{-border}; $w += $this->{-ipadleft} + $this->{-ipadright}; my $h = @lines; $h += 2; # empty line + line of buttons $h += 3; # for textentry widget $h += 2; # border of textviewer $h += 2 if $this->{-border}; $h += $this->{-ipadtop} + $this->{-ipadbottom}; $this->{-width} = $w; $this->{-height} = $h; $this->SUPER::layout; return $this; } sub get() { my $this = shift; return undef if $this->{-cancelled}; $this->getobj('answer')->get; } 1; =head1 NAME Curses::UI::Dialog::Question - Pose a simple question to the user =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Question =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Question', -question => 'How super awesome are you?' ); $dialog->modalfocus; $win->delete('mydialog'); # The easy way (see Curses::UI documentation). # -------------------------------------------- my $value = $cui->question(-question => 'How super awesome are you?'); # or even my $awesomeness = $cui->question('How super awesome are you?'); =head1 DESCRIPTION Curses::UI::Dialog::Question is a basic question dialog. This type of dialog has a message on it, a TextEntry answer box, and one or more buttons. It can be used to have a user enter some answer in response to a question. See exampes/demo-widgets in the distribution for a short demo. =head1 OPTIONS =over 4 =item * B<-title> < TEXT > Set the title of the dialog window to TEXT. =item * B<-question> < TEXT > This option sets the question to show to TEXT. The text may contain newline (\n) characters. =item * B<-buttons> < ARRAYREF > =item * B<-selected> < INDEX > =item * B<-buttonalignment> < VALUE > These options sets the buttons that have to be used. For an explanation of these options, see the L documentation. =back =head1 METHODS =over 4 =item * B ( HASH ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will call B on the TextEntry object of the dialog and return its returnvalue. See L for more information on this. If the cancel button was pressed, the return value will be undef. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2004 Luke Closs . All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/Calendar.pm0000644000175000001440000001332311627564365020076 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Calendar # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Calendar; use strict; use Curses; use Curses::UI::Window; use Curses::UI::Common; use Curses::UI::Widget; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Window Curses::UI::Common ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -title => undef, -date => undef, -fg => -1, -bg => -1, %userargs, -selected_date => undef, -border => 1, -centered => 1, -titleinverse => 0, -ipad => 1, ); my $this = $class->SUPER::new(%args); my $l = $this->root->lang; my $buttons = $this->add( 'buttons', 'Buttonbox', -y => -1, -x => 0, -width => undef, -buttonalignment => 'right', -buttons => [ 'ok', 'cancel' ], -bg => $this->{-bg}, -fg => $this->{-fg}, ); # Let the window in which the buttons are loose focus # if a button is pressed. $buttons->set_routine( 'press-button', \&press_button_callback ); my $calendar = $this->add( 'calendar', 'Calendar', -border => 0, -padbottom => 1, -date => $this->{-date}, -bg => $this->{-bg}, -fg => $this->{-fg}, )->focus; # Selecting a date may bring the focus to the OK button. $calendar->set_routine('date-select', sub{ my $cal = shift; $cal->date_select; $cal->parent->getobj('buttons')->{-selected} = 0; $cal->loose_focus; }); # Doubleclick on calendar may close the dialog. if ( $Curses::UI::ncurses_mouse ) { $calendar->set_mouse_binding(sub { my $buttons = shift(); my @extra = @_; my $this = $buttons->parent; $buttons->do_routine('mouse-button', @extra); $this->{-selected_date} = $this->getobj('calendar')->get; $this->loose_focus; }, BUTTON1_DOUBLE_CLICKED()); } # Escape should close the dialog, without setting a date. $this->set_binding(sub { my $this = shift; $this->{-selected_date} = undef; $this->loose_focus; }, CUI_ESCAPE()); $this->layout(); return bless $this, $class; } sub layout() { my $this = shift; my $cal = $this->getobj('calendar'); if ($cal) { $this->{-width} = width_by_windowscrwidth( $this->getobj('calendar')->{-width}, %$this); $this->{-height} = height_by_windowscrheight( $this->getobj('calendar')->{-height}, %$this); } $this->SUPER::layout() or return; return $this; } sub get() { my $this = shift; return $this->{-selected_date}; } sub press_button_callback() { my $buttons = shift; my $this = $buttons->parent; my $ok_pressed = $buttons->get; if ($ok_pressed) { $this->{-selected_date} = $this->getobj('calendar')->get; } else { $this->{-selected_date} = undef; } $this->loose_focus; } 1; =pod =head1 NAME Curses::UI::Dialog::Calendar - Create and manipulate calendar dialogs =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Calendar =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Calendar' ); $dialog->modalfocus; $win->delete('mydialog'); my $date = $dialog->get(); # The easy way (see Curses::UI documentation). # -------------------------------------------- $date = $cui->calendardialog(); =head1 DESCRIPTION Curses::UI::Dialog::Calendar is a calendar dialog. This type of dialog can be used to select a date. See exampes/demo-widgets in the distribution for a short demo. =head1 OPTIONS =over 4 =item * B<-title> < TEXT > Set the title of the dialog window to TEXT. =item * B<-date> < DATE > Set the date to start with to DATE. If -date is not defined, today will be used as the startdate. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the date that was selected or undef if no date was selected. =back =head1 SPECIAL BINDINGS =over 4 =item * B This will invoke the cancel button, so the calendar dialog returns without selecting any date. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/Status.pm0000644000175000001440000001071611627564365017653 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Status # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Status; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Window; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Window Curses::UI::Common ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -message => undef, # The message to show -ipad => 1, -border => 1, -width => undef, -height => undef, -fg => -1, -bg => -1, %userargs, -centered => 1, ); my $this = $class->SUPER::new(%args); $args{-message} = 'no message' unless defined $args{-message}; my $l = $this->add( 'label', 'Label', -text => $this->{-message}, -fg => $this->{-fg}, -bg => $this->{-bg}, ); $this->layout(); bless $this, $class; } # There is no need to focus a status dialog sub focus() {} ; sub layout() { my $this = shift; my $label = $this->getobj('label'); # The label might not be added at this point. if (defined $label) { # Compute the width the dialog window needs. if (not defined $this->{-width}) { $this->{-width} = $this->width_by_windowscrwidth( $label->{-width} + 1, # +1 for visible cursor %$this ); } # Compute the height the dialog window needs. if (not defined $this->{-height}) { $this->{-height} = $this->height_by_windowscrheight( $label->{-height}, %$this ); } } $this->SUPER::layout or return; return $this; } sub message($;) { my $this = shift; my $message = shift; $message = 'no message' unless defined $message; $this->getobj('label')->text($message); return $this; } 1; =pod =head1 NAME Curses::UI::Dialog::Status - Create and manipulate status dialogs =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Status =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Status', -message => 'Hello, world!', ); $dialog->draw(); $win->delete('mydialog'); # The easy way (see Curses::UI documentation). # -------------------------------------------- $cui->status( -message => 'Some message' ); # or even: $cui->status( 'Some message' ); $cui->nostatus; =head1 DESCRIPTION Curses::UI::Dialog::Status is not really a dialog, since the user has no way of interacting with it. It is merely a way of presenting status information to the user of your program. See exampes/demo-Curses::UI::Dialog::Status in the distribution for a short demo. =head1 OPTIONS =over 4 =item * B<-title> < TEXT > Set the title of the dialog window to TEXT. =item * B<-message> < TEXT > This option sets the initial message to show to TEXT. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) These are standard methods. See L for an explanation of these. =item * B ( TEXT ) This method will update the message of the status dialog to TEXT. For this update to show, you will have to call the B method of the progress dialog. =back =head1 SEE ALSO L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/Basic.pm0000644000175000001440000001720511627564365017411 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Basic # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Basic; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Window; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Window Curses::UI::Common ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -border => 1, -message => '', # The message to show -ipad => 1, -fg => -1, -bg => -1, %userargs, -titleinverse => 1, -centered => 1, ); # Create a new object, but remember the current # screen_too_small setting. The width needed for the # buttons can only be computed in the second run # of focus() and we do not want the first run to # set screen_too_small to a true value because # of this. # my $remember = $Curses::UI::screen_too_small; my $this = $class->SUPER::new(%args); $this->add('message', 'TextViewer', -border => 1, -vscrollbar => 1, -wrapping => 1, -padbottom => 2, -text => $this->{-message}, -bg => $this->{-bg}, -fg => $this->{-fg}, -bbg => $this->{-bg}, -bfg => $this->{-fg}, -focusable => 0, ); # Create a hash with arguments that may be passed to # the Buttonbox class. my %buttonargs = ( -buttonalignment => 'right', ); foreach my $arg (qw(-buttons -selected -buttonalignment)) { $buttonargs{$arg} = $this->{$arg} if exists $this->{$arg}; } my $b = $this->add( 'buttons', 'Buttonbox', -y => -1, -bg => $this->{-bg}, -fg => $this->{-fg}, %buttonargs ); # Let the window in which the buttons are loose focus # if a button is pressed. $b->set_routine( 'press-button', sub { my $this = shift; my $parent = $this->parent; $parent->loose_focus(); } ); # Restore screen_too_small (see above) and # start the second layout pass. $Curses::UI::screen_too_small = $remember; $this->layout; # Set the initial focus to the buttons. $b->focus; return bless $this, $class; } # TODO delete_curses_windows sub layout() { my $this = shift; return $this if $Curses::UI::screen_too_small; # The maximum available space on the screen. my $avail_width = $ENV{COLS}; my $avail_height = $ENV{LINES}; # Compute the maximum available space for the message. $this->process_padding; my $avail_textwidth = $avail_width; $avail_textwidth -= 2; # border for the textviewer $avail_textwidth -= 2 if $this->{-border}; $avail_textwidth -= $this->{-ipadleft} - $this->{-ipadright}; my $avail_textheight = $avail_height; $avail_textheight -= 2; # border for the textviewer $avail_textheight -= 2; # empty line and line of buttons $avail_textheight -= 2 if $this->{-border}; $avail_textheight -= $this->{-ipadtop} - $this->{-ipadbottom}; # Break up the message in separate lines if neccessary. my @lines = (); foreach (split (/\n/, $this->{-message})) { push @lines, @{text_wrap($_, $avail_textwidth)}; } # Compute the longest line in the message. my $longest_line = 0; foreach (@lines) { $longest_line = length($_) if (length($_) > $longest_line); } # Compute the width of the buttons (if the buttons # object is available. This is not the case just after # new() calls SUPER::new()). my $buttons = $this->getobj('buttons'); my $button_width = 0; if (defined $buttons) { $button_width = $buttons->compute_buttonwidth; } # Decide what is the longest line. $longest_line = $button_width if $longest_line < $button_width; # Check if there is enough space to show the widget. if ($avail_textheight < 1 or $avail_textwidth < $longest_line) { $Curses::UI::screen_too_small = 1; return $this; } # Compute the size of the widget. my $w = $longest_line; $w += 2; # border of textviewer $w += 2; # extra width for preventing wrapping of text $w += 2 if $this->{-border}; $w += $this->{-ipadleft} + $this->{-ipadright}; my $h = @lines; $h += 2; # empty line + line of buttons $h += 2; # border of textviewer $h += 2 if $this->{-border}; $h += $this->{-ipadtop} + $this->{-ipadbottom}; $this->{-width} = $w; $this->{-height} = $h; $this->SUPER::layout; return $this; } sub get() { my $this = shift; $this->getobj('buttons')->get; } 1; =pod =head1 NAME Curses::UI::Dialog::Basic - Create and manipulate basic dialogs =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Basic =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Basic', -message => 'Hello, world!' ); $dialog->focus; $win->delete('mydialog'); # The easy way (see Curses::UI documentation). # -------------------------------------------- my $buttonvalue = $cui->dialog(-message => 'Hello, world!'); # or even $cui->dialog('Hello, world!'); =head1 DESCRIPTION Curses::UI::Dialog::Basic is a basic dialog. This type of dialog has a message on it and one or more buttons. It can be used to show a message to the user of your program ("The thingy has been updated") or to get some kind of confirmation from the user ("Are you sure you want to update the thingy?"). See exampes/demo-Curses::UI::Dialog::Basic in the distribution for a short demo. =head1 OPTIONS =over 4 =item * B<-title> < TEXT > Set the title of the dialog window to TEXT. =item * B<-message> < TEXT > This option sets the message to show to TEXT. The text may contain newline (\n) characters. =item * B<-buttons> < ARRAYREF > =item * B<-selected> < INDEX > =item * B<-buttonalignment> < VALUE > These options sets the buttons that have to be used. For an explanation of these options, see the L documentation. =back =head1 METHODS =over 4 =item * B ( HASH ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will call B on the buttons object of the dialog and return its returnvalue. See L for more information on this. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/Error.pm0000644000175000001440000000665011627564365017463 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Error # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Error; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Dialog::Basic; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Dialog::Basic Curses::UI::Common ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -message => '', # The message to show -fg => -1, -bg => -1, %userargs, -ipadleft => 10, # Space for sign -centered => 1, ); my $this = $class->SUPER::new(%args); unless (defined $this->{-title}) { my $l = $this->root->lang; $this->title($l->get('error_title')); } bless $this, $class; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw widget $this->SUPER::draw(1) or return $this; # Draw sign $this->{-borderscr}->addstr(2, 1, " _"); $this->{-borderscr}->addstr(3, 1, " / \\"); $this->{-borderscr}->addstr(4, 1, " / ! \\"); $this->{-borderscr}->addstr(5, 1, " /_____\\"); $this->{-borderscr}->noutrefresh(); $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } 1; =pod =head1 NAME Curses::UI::Dialog::Error - Create and manipulate error dialogs =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Basic | +----Curses::UI::Dialog::Error =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Error', -message => 'The world has gone!' ); $dialog->focus; $win->delete('mydialog'); # The easy way (see Curses::UI documentation). # -------------------------------------------- $cui->error(-message => 'The world has gone!'); # or even: $cui->error('The world has gone!'); =head1 DESCRIPTION Curses::UI::Dialog::Error is a basic error dialog. It is almost the same as L, except for the fact that a warning sign is drawn to the left of the message using ASCII "art": _ / \ / ! \ /_____\ Since this class is very closely related to the basic dialog, see L for a description of the options and methods that you can use. =head1 SEE ALSO L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/Progress.pm0000644000175000001440000001437611627564365020202 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Progress # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Progress; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Window; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Window Curses::UI::Common ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -nomessage => 0, # Do we want a message or not? -message => '', # The message to show -min => undef, # Arguments for the progressbar -max => undef, -pos => undef, -nocenterline => undef, -nopercentage => undef, -ipad => 1, # Default widget settings -border => 1, -width => 60, -height => undef, -fg => -1, -bg => -1, %userargs, -centered => 1, ); my $this = $class->SUPER::new(%args); unless ($args{-nomessage}) { $this->add( 'label', 'Label', -width => -1, -text => $this->{-message}, -intellidraw => 0, ); } # Create the progress bar arguments. my %pb_args = (); foreach my $var (qw(-min -max -pos -nopercentage -nocenterline)) { if (defined $this->{$var}) { $pb_args{$var} = $this->{$var}; } } $this->add( 'progressbar', 'Progressbar', -y => -1, -width => -1, -fg => $this->{-fg}, -bg => $this->{-bg}, %pb_args, -intellidraw => 0, ); $this->layout(); bless $this, $class; } # There is no need to focus a progress dialog sub focus() {} ; sub layout() { my $this = shift; if (not defined $this->{-height} and defined $this->getobj('progressbar')) { # Space between progressbar and message. my $need = ($this->{-nomessage} ? 0 : 1); # The height for the message. if (defined $this->getobj('label')) { $need += $this->getobj('label')->height; } # The height for the progressbar. if (defined $this->getobj('progressbar')) { my $pbheight = $this->getobj('progressbar')->height; $need += $pbheight; } my $height = $this->height_by_windowscrheight($need, %$this); $this->{-height} = $height; } $this->SUPER::layout or return; return $this; } sub pos($;) { my $this = shift; my $pos = shift; $this->getobj('progressbar')->pos($pos); return $this; } sub message() { my $this = shift; return $this if $this->{-nomessage}; my $msg = shift; $this->getobj('label')->text($msg); return $this; } 1; =pod =head1 NAME Curses::UI::Dialog::Progress - Create and manipulate progress dialogs =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Progress =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Progress', -max => 100, -message => 'Some message', ); $dialog->pos(10); $dialog->message('Some other message'); $dialog->draw(); $win->delete('mydialog'); # The easy way (see Curses::UI documentation). # -------------------------------------------- $cui->progress( -max => 100, -message => 'Some message', ); $cui->setprogress(10, 'Some other message'); $cui->noprogress; =head1 DESCRIPTION Curses::UI::Dialog::Progress is not really a dialog, since the user has no way of interacting with it. It is merely a way of presenting progress information to the user of your program. See exampes/demo-Curses::UI::Dialog::Progress in the distribution for a short demo. =head1 OPTIONS =over 4 =item * B<-title> < TEXT > Set the title of the dialog window to TEXT. =item * B<-message> < TEXT > This option sets the initial message to show to TEXT. This message is displayed using a L, so it can not contain any newline (\n) characters. =item * B<-nomessage> < BOOLEAN > If BOOLEAN has a true value, the dialog window will not contain a message label. By default B<-nomessage> has a false value. =item * B<-min> < VALUE > =item * B<-max> < VALUE > =item * B<-pos> < VALUE > =item * B<-nopercentage> < BOOLEAN > =item * B<-nocenterline> < BOOLEAN > These options control the progressbar of the dialog. For an explanation of these options, see L. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) These are standard methods. See L for an explanation of these. =item * B ( VALUE ) This method will update the position of the progressbar to SCALAR. You will have to call the B method to see the changes. =item * B ( TEXT ) This method will update the message of the progress dialog to TEXT. You will have to call the B method to see the changes. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/Dirbrowser.pm0000644000175000001440000002424411627564365020513 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Dirbrowser # (C) 2003 by Roberto De Leo based on work # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Dirbrowser; use strict; use Curses; use Curses::UI::Window; use Curses::UI::Common; use Cwd; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Window Curses::UI::Common ); $VERSION = '1.0'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -title => undef, -path => undef, -bg => -1, -fg => -1, %userargs, -border => 1, -centered => 1, -titleinverse => 0, -ipad => 1, -selected_cache => {}, ); # Does -path not contain a path? Then use the # current working directory. if (not defined $args{-path} or $args{-path} =~ /^\s*$/) { $args{-path} = cwd; } my $this = $class->SUPER::new(%args); $this->layout(); my $l = $this->root->lang; # Start at home? Goto the homedirectory of the current user # if the -path is not defined. $this->goto_homedirectory unless defined $this->{-path}; my $buttons = $this->add( 'buttons', 'Buttonbox', -y => -1, -x => 0, -width => undef, -buttonalignment => 'middle', -buttons => [ 'ok', 'cancel' ], -bg => $this->{-bg}, -fg => $this->{-fg}, ); # Let the window in which the buttons are loose focus # if a button is pressed. $buttons->set_routine( 'press-button', \&press_button_callback ); my $one_up = $l->get('file_dirup'); my $dirbrowser = $this->add( 'dirbrowser', 'Listbox', -y => 0, -border => 1, -width => $this->canvaswidth - 2, -padbottom => 6, -values => [], -vscrollbar => 1, -labels => { '..' => ".. ($one_up)" }, -bg => $this->{-bg}, -fg => $this->{-fg}, -bbg => $this->{-bg}, -bfg => $this->{-fg}, ); $dirbrowser->set_routine('option-select',\&dirselect); $dirbrowser->set_routine('goto-homedirectory',\&select_homedirectory); $dirbrowser->set_binding('goto-homedirectory', '~'); # Get language specific data. my $l_path = $l->get('file_path'); my $l_mask = $l->get('file_mask'); my $l_file = $l->get('file_file'); my $l_len = $l->get('file_labelsize'); my $labeloffset = 1; my $textoffset = $l_len + 2; $this->add( 'pathlabel', 'Label', -x => $labeloffset, -y => $this->canvasheight - 5, -text => $l_path, -bg => $this->{-bg}, -fg => $this->{-fg}, ); $this->add( 'pathvalue', 'Label', -x => $textoffset, -y => $this->canvasheight - 5, -width => $this->canvaswidth - 6, -text => $this->{-path}, -bg => $this->{-bg}, -fg => $this->{-fg}, ); $this->set_binding(sub{ my $this = shift; $this->getobj('buttons')->{-selected} = 1; $this->loose_focus; }, CUI_ESCAPE); $this->layout(); $this->get_dir; return bless $this, $class; } sub layout() { my $this = shift; my $w = 50; my $h = 18; $this->{-width} = $w, $this->{-height} = $h, $this->SUPER::layout() or return; return $this; } sub get_dir() { my $this = shift; # Get pathvalue, filevalue, dirbrowser and filebrowser objects. my $pv = $this->getobj('pathvalue'); my $db = $this->getobj('dirbrowser'); my $path = $pv->text; # Resolve path. $path =~ s|/+|/|g; my @path = split /\//, $path; my @resolved = (); foreach my $dir (@path) { if ($dir eq '.') { next } elsif ($dir eq '..') { pop @resolved if @resolved } else { push @resolved, $dir } } $path = join "/", @resolved; # Catch totally bogus paths. if (not -d $path) { $path = "/" } $pv->text($path); my @dirs = (); unless (opendir D, $path) { my $l = $this->root->lang(); my $error = $l->get('file_err_opendir_pre') . $path . $l->get('file_err_opendir_post') . ":\n$!"; $this->root->error($error); return; } foreach my $f (sort readdir D) { next if $f =~ /^\.$|^\.\.$/; next if $f =~ /^\./ and not $this->{-show_hidden}; push @dirs, $f if -d "$path/$f"; } closedir D; unshift @dirs, ".." if $path ne '/'; $db->values(\@dirs); $db->{-ypos} = $this->{-selected_cache}->{$path}; $db->{-ypos} = 0 unless defined $db->{-ypos}; $db->{-selected} = undef; $db->layout_content->draw(1); return $this; } # Set $this->{-path} to the homedirectory of the current user. sub goto_homedirectory() { my $this = shift; my @pw = getpwuid($>); if (@pw) { if (-d $pw[7]) { $this->{-path} = $pw[7]; } else { $this->{-path} = '/'; $this->root->error("Homedirectory $pw[7] not found"); return; } } else { $this->{-path} = '/'; $this->root->error("Can't find a passwd entry for uid $>"); return; } return $this; } sub select_homedirectory() { my $b = shift; # dir-/filebrowser my $this = $b->parent; my $pv = $this->getobj('pathvalue'); $this->goto_homedirectory or return $b; $pv->text($this->{-path}); $this->get_dir; return $b; } sub dirselect() { my $db = shift; # dirbrowser my $this = $db->parent; my $pv = $this->getobj('pathvalue'); # Find the new path. my $add = $db->values->[$db->{-ypos}]; my $savepath = $pv->text; $this->{-selected_cache}->{$savepath} = $db->{-ypos}; $pv->text("/$savepath/$add"); # Get the selected directory. unless ($this->get_dir) { $pv->text($savepath); } return $db; } sub maskbox_onchange() { my $maskbox = shift; my $this = $maskbox->parent; $this->{-activemask} = $maskbox->get; $this->get_dir; return $maskbox; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw Window $this->SUPER::draw(1) or return $this; $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } sub get() { my $this = shift; if ($this->getobj('buttons')->get) { my $file = $this->getobj('pathvalue')->get; $file =~ s|/+|/|g; return $file; } else { return; } } sub press_button_callback() { my $buttons = shift; my $this = $buttons->parent; my $file = $this->get; my $ok_pressed = $buttons->get; if ($ok_pressed and $file =~ m|/$|) { my $l = $this->root->lang; $this->root->error($l->get('file_err_nofileselected')); return; } else { $this->loose_focus; } } 1; =pod =head1 NAME Curses::UI::Dialog::Dirbrowser - Create and manipulate filebrowser dialogs =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Dirbrowser =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Dirbrowser' ); $dialog->focus; my $file = $dialog->get(); $win->delete('mydialog'); # The easy way (see Curses::UI documentation). # -------------------------------------------- $file = $cui->filebrowser(); $file = $cui->loadfilebrowser(); $file = $cui->savefilebrowser(); =head1 DESCRIPTION Curses::UI::Dialog::Dirbrowser is a dirbrowser dialog. This type of dialog can be used to select a directory, anywhere on the filesystem. See exampes/demo-Curses::UI::Dialog::Dirbrowser in the distribution for a short demo. =head1 OPTIONS =over 4 =item * B<-title> < TEXT > Set the title of the dialog window to TEXT. =item * B<-path> < PATH > Set the path to start with to PATH. If this path does not exist, the filebrowser will start in the rootdirectory. =item * B<-show_hidden> < BOOLEAN > If BOOLEAN has a true value, hidden files (the filename starts with a dot) will also be shown. By default this option is set to false. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the complete path to the file that was selected using the filebrowser. If no file was selected, this method will return an undefined value. =back =head1 SPECIAL BINDINGS =over 4 =item * B This will invoke the cancel button, so the filebrowser widget returns without selecting any file. =item * B<~> If the directory- or filelistbox of the dialog window has the focus and the tilde (~) button is pressed, the filebrowser will chdir to the homedirectory of the current user. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Dialog/Filebrowser.pm0000644000175000001440000003754311627564365020662 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Dialog::Filebrowser # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Dialog::Filebrowser; use strict; use Curses; use Curses::UI::Window; use Curses::UI::Common; use Cwd; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Window Curses::UI::Common ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -title => undef, -path => undef, -file => '', -show_hidden => 0, -mask => undef, -mask_selected => 0, -editfilename => 0, -bg => -1, -fg => -1, %userargs, -border => 1, -centered => 1, -titleinverse => 0, -ipad => 1, -selected_cache => {}, ); # Does -file contain a path? Then do some splitting. if (defined $args{-file} and $args{-file} =~ m|/|) { my $file = ""; my $path = ""; my @path = split /\//, $args{-file}; $file = pop @path; if (@path) { $path = join "/", @path; } $args{-path} = $path; $args{-file} = $file; } # Does -path not contain a path? Then use the # current working directory. if (not defined $args{-path} or $args{-path} =~ /^\s*$/) { $args{-path} = cwd; } my $this = $class->SUPER::new(%args); $this->layout(); my $l = $this->root->lang; # Start at home? Goto the homedirectory of the current user # if the -path is not defined. $this->goto_homedirectory unless defined $this->{-path}; my $buttons = $this->add( 'buttons', 'Buttonbox', -y => -1, -x => 0, -width => undef, -buttonalignment => 'right', -buttons => [ 'ok', 'cancel' ], -bg => $this->{-bg}, -fg => $this->{-fg}, ); # Let the window in which the buttons are loose focus # if a button is pressed. $buttons->set_routine( 'press-button', \&press_button_callback ); my $one_up = $l->get('file_dirup'); my $dirbrowser = $this->add( 'dirbrowser', 'Listbox', -y => 0, -border => 1, -width => int(($this->canvaswidth - 3)/2), -padbottom => 6, -values => [], -vscrollbar => 1, -labels => { '..' => ".. ($one_up)" }, -bg => $this->{-bg}, -fg => $this->{-fg}, -bbg => $this->{-bg}, -bfg => $this->{-fg}, ); $dirbrowser->set_routine('option-select',\&dirselect); $dirbrowser->set_routine('goto-homedirectory',\&select_homedirectory); $dirbrowser->set_binding('goto-homedirectory', '~'); my $filebrowser = $this->add( 'filebrowser', 'Listbox', -y => 0, -x => $this->getobj('dirbrowser')->width + 1, -border => 1, -padbottom => 6, -vscrollbar => 1, -values => ["info.txt","passwd"], -bg => $this->{-bg}, -fg => $this->{-fg}, -bbg => $this->{-bg}, -bfg => $this->{-fg}, ); $filebrowser->set_routine('option-select', \&fileselect); $filebrowser->set_routine('goto-homedirectory',\&select_homedirectory); $filebrowser->set_binding('goto-homedirectory', '~'); # Get language specific data. my $l_path = $l->get('file_path'); my $l_mask = $l->get('file_mask'); my $l_file = $l->get('file_file'); my $l_len = $l->get('file_labelsize'); my $labeloffset = 1; my $textoffset = $l_len + 2; $this->add( 'pathlabel', 'Label', -x => $labeloffset, -y => $this->canvasheight - 5, -text => $l_path, -bg => $this->{-bg}, -fg => $this->{-fg}, ); $this->add( 'pathvalue', 'Label', -x => $textoffset, -y => $this->canvasheight - 5, -width => $this->canvaswidth - 6, -text => $this->{-path}, -bg => $this->{-bg}, -fg => $this->{-fg}, ); $this->add( 'filelabel', 'Label', -x => $labeloffset, -y => $this->canvasheight - 4, -text => $l_file, -bg => $this->{-bg}, -fg => $this->{-fg}, ); if ($this->{-editfilename}) { $this->add( 'filevalue', 'TextEntry', -x => $textoffset, -y => $this->canvasheight - 4, -text => $this->{-file}, -width => 32, -showlines => 1, -border => 0, -sbborder => 0, -regexp => '/^[^\/]*$/', -bg => $this->{-bg}, -fg => $this->{-fg}, ); } else { $this->add( 'filevalue', 'Label', -x => $textoffset, -y => $this->canvasheight - 4, -text => $this->{-file}, -width => $this->canvaswidth - 6, -bg => $this->{-bg}, -fg => $this->{-fg}, ); } if (defined $this->{-mask} and ref $this->{-mask} eq 'ARRAY') { $this->add( 'masklabel', 'Label', -x => $labeloffset, -y => $this->canvasheight - 2, -text => $l_mask, -bg => $this->{-bg}, -fg => $this->{-fg}, ); my @values = (); my %labels = (); my $i =0; foreach my $mask (@{$this->{-mask}}) { push @values, $mask->[0]; $labels{$mask->[0]} = $mask->[1]; } my $maskbox = $this->add( 'maskbox', 'Popupmenu', -x => $textoffset, -y => $this->canvasheight - 2, -values => \@values, -labels => \%labels, -selected => $this->{-mask_selected}, -onchange => \&maskbox_onchange, -bg => $this->{-bg}, -fg => $this->{-fg}, ); $this->{-activemask} = $maskbox->get; } $this->set_binding(sub{ my $this = shift; $this->getobj('buttons')->{-selected} = 1; $this->loose_focus; }, CUI_ESCAPE); $this->layout(); $this->get_dir; if ($this->{-editfilename}) { $this->getobj('filevalue')->focus; } else { $this->getobj('filebrowser')->focus; } return bless $this, $class; } sub layout() { my $this = shift; my $w = 60; my $h = 18; $h += 2 if defined $this->{-mask}; $this->{-width} = $w, $this->{-height} = $h, $this->SUPER::layout() or return; return $this; } sub get_dir() { my $this = shift; # Get pathvalue, filevalue, dirbrowser and filebrowser objects. my $pv = $this->getobj('pathvalue'); my $db = $this->getobj('dirbrowser'); my $fb = $this->getobj('filebrowser'); my $path = $pv->text; # Resolve path. $path =~ s|/+|/|g; my @path = split /\//, $path; my @resolved = (); foreach my $dir (@path) { if ($dir eq '.') { next } elsif ($dir eq '..') { pop @resolved if @resolved } else { push @resolved, $dir } } $path = join "/", @resolved; # Catch totally bogus paths. if (not -d $path) { $path = "/" } $pv->text($path); my @dirs = (); my @files = (); unless (opendir D, $path) { my $l = $this->root->lang(); my $error = $l->get('file_err_opendir_pre') . $path . $l->get('file_err_opendir_post') . ":\n$!"; $this->root->error($error); return; } foreach my $f (sort readdir D) { next if $f =~ /^\.$|^\.\.$/; next if $f =~ /^\./ and not $this->{-show_hidden}; push @dirs, $f if -d "$path/$f"; if (-f "$path/$f") { $this->{-activemask} = '.' unless defined $this->{-activemask}; push @files, $f if $f =~ /$this->{-activemask}/i; } } closedir D; unshift @dirs, ".." if $path ne '/'; $db->values(\@dirs); $db->{-ypos} = $this->{-selected_cache}->{$path}; $db->{-ypos} = 0 unless defined $db->{-ypos}; $db->{-selected} = undef; $db->layout_content->draw(1); $fb->values(\@files); $fb->{-ypos} = $fb->{-yscrpos} = 0; $fb->layout_content->draw(1); return $this; } # Set $this->{-path} to the homedirectory of the current user. sub goto_homedirectory() { my $this = shift; my @pw = getpwuid($>); if (@pw) { if (-d $pw[7]) { $this->{-path} = $pw[7]; } else { $this->{-path} = '/'; $this->root->error("Homedirectory $pw[7] not found"); return; } } else { $this->{-path} = '/'; $this->root->error("Can't find a passwd entry for uid $>"); return; } return $this; } sub select_homedirectory() { my $b = shift; # dir-/filebrowser my $this = $b->parent; my $pv = $this->getobj('pathvalue'); $this->goto_homedirectory or return $b; $pv->text($this->{-path}); $this->get_dir; return $b; } sub dirselect() { my $db = shift; # dirbrowser my $this = $db->parent; my $fv = $this->getobj('filevalue'); my $pv = $this->getobj('pathvalue'); # Find the new path. my $add = $db->values->[$db->{-ypos}]; my $savepath = $pv->text; $this->{-selected_cache}->{$savepath} = $db->{-ypos}; $pv->text("/$savepath/$add"); # Clear the filename field if the filename # may not be edited. $fv->text('') unless $this->{-editfilename}; # Get the selected directory. unless ($this->get_dir) { $pv->text($savepath); } return $db; } sub fileselect() { my $filebrowser = shift; my $this = $filebrowser->parent; my $selected = $filebrowser->{-ypos}; my $file = $filebrowser->values->[$selected]; if (defined $file) { $this->{-file} = $file; $this->getobj('filevalue')->text($file); } # TODO: find out if it is done by mouseclick. If yes, then do # not change focus. # Doubleclick may also select the file. # $this->getobj('buttons')->focus; } sub maskbox_onchange() { my $maskbox = shift; my $this = $maskbox->parent; $this->{-activemask} = $maskbox->get; $this->get_dir; return $maskbox; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw Window $this->SUPER::draw(1) or return $this; $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } sub get() { my $this = shift; if ($this->getobj('buttons')->get) { my $file = $this->getobj('pathvalue')->get . "/" . $this->getobj('filevalue')->get; $file =~ s|/+|/|g; return $file; } else { return; } } sub press_button_callback() { my $buttons = shift; my $this = $buttons->parent; my $file = $this->get; my $ok_pressed = $buttons->get; if ($ok_pressed and $file =~ m|/$|) { my $l = $this->root->lang; $this->root->error($l->get('file_err_nofileselected')); return; } else { $this->loose_focus; } } 1; =pod =head1 NAME Curses::UI::Dialog::Filebrowser - Create and manipulate filebrowser dialogs =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window | +----Curses::UI::Dialog::Filebrowser =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); # The hard way. # ------------- my $dialog = $win->add( 'mydialog', 'Dialog::Filebrowser' ); $dialog->focus; my $file = $dialog->get(); $win->delete('mydialog'); # The easy way (see Curses::UI documentation). # -------------------------------------------- $file = $cui->filebrowser(); $file = $cui->loadfilebrowser(); $file = $cui->savefilebrowser(); =head1 DESCRIPTION Curses::UI::Dialog::Filebrowser is a filebrowser dialog. This type of dialog can be used to select a file, anywhere on the filesystem. See exampes/demo-Curses::UI::Dialog::Filebrowser in the distribution for a short demo. =head1 OPTIONS =over 4 =item * B<-title> < TEXT > Set the title of the dialog window to TEXT. =item * B<-path> < PATH > Set the path to start with to PATH. If this path does not exist, the filebrowser will start in the rootdirectory. =item * B<-file> < FILE > Set the filename to start with to FILE. =item * B<-editfilename> < BOOLEAN > If BOOLEAN has a true value, the user may edit the filename. This is for example useful for a filebrowser that is used to select a filename to save to. By default this option is set to false. =item * B<-show_hidden> < BOOLEAN > If BOOLEAN has a true value, hidden files (the filename starts with a dot) will also be shown. By default this option is set to false. =item * B<-mask> < ARRAYREF > If B<-mask> is defined, a filemask popupbox will be added to the filebrowser dialog window. This popupbox will filter the list of files that is displayed, using a regular expression (case insensitive). The ARRAYREF contains a list of array references. Each array reference has two elements: a regexp and a description. Here's an example B<-mask>: my $mask = [ [ '.', 'All files (*)' ], [ '\.txt$', 'Text files (*.txt)' ] [ 'howto', 'HOWTO documentation' ], [ 'core', 'Core files' ], ]; =item * B<-mask_selected> < INDEX > Normally the first mask in the list of masks will be made active upon creation of the filebrowser. If you want another mask to be active, use the B<-mask_selected> option. Set this value to the index of the mask you want to be active. For example: if you would want the "howto" mask in the above example to be active, you would use the value 2 for B<-mask_selected>. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the complete path to the file that was selected using the filebrowser. If no file was selected, this method will return an undefined value. =back =head1 SPECIAL BINDINGS =over 4 =item * B This will invoke the cancel button, so the filebrowser widget returns without selecting any file. =item * B<~> If the directory- or filelistbox of the dialog window has the focus and the tilde (~) button is pressed, the filebrowser will chdir to the homedirectory of the current user. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Window.pm0000644000175000001440000001040511627564365016433 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Window # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Window; use strict; use Curses; use Curses::UI::Container; use Curses::UI::Common; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Container ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); # Create the window. my $this = $class->SUPER::new( -width => undef, -height => undef, -x => 0, -y => 0, -centered => 0, # Center the window in the display? %userargs, -nocursor => 1, # This widget does not use a cursor -assubwin => 1, # Always constructed as a subwindow ); return $this; } sub layout () { my $this = shift; # Compute the coordinates of the Window if # it has to be centered. if ($this->{-centered}) { # The maximum available space on the screen. my $avail_width = $ENV{COLS}; my $avail_height = $ENV{LINES}; # Compute the coordinates for the widget. my $w = $this->{-width} || 1; my $h = $this->{-height} || 1; my $x = int(($avail_width - $w) / 2); my $y = int(($avail_height - $h) / 2); $x = 0 if $x < 0; $y = 0 if $y < 0; $this->{-x} = $x; $this->{-y} = $y; } $this->SUPER::layout or return; return $this; } 1; =pod =head1 NAME Curses::UI::Window - Create and manipulate Window widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Window =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add( 'window_id', 'Window', %options, ); =head1 DESCRIPTION Curses::UI::Window is a window widget. It can be added to a Curses::UI instance. After that the window can be filled with other widgets to create an application window. For information on how to fill the window with widgets, see L. =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-centered> < BOOLEAN > A window can automatically be drawn in the center of the screen. To enable this option use a true value and to disable it use a false value. The default is not to center a window. Example: $cui->add('mywindow', 'Window', -centered => 1); =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) If this method is called, the window will get modal focus. This means that all events will be sent to this window. By calling the B method, the window will loose its focus. =item * B ( ) This method will have the window loose its focus (using this method you can also let a modal focused window loose its focus). =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/TextViewer.pm0000644000175000001440000000423311627564365017274 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::TextViewer # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::TextViewer; use strict; use Curses; use Curses::UI::Common; use Curses::UI::TextEditor; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::TextEditor ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( %userargs, -readonly => 1, ); return $class->SUPER::new( %args); } 1; =pod =head1 NAME Curses::UI::TextViewer - Create and manipulate textviewer widgets =head1 CLASS HIERARCHY Curses::UI::Widget Curses::UI::Searchable | +----Curses::UI::TextEditor | +----Curses::UI::TextViewer =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $textviewer = $win->add( 'mytextviewer', 'TextViewer', -text => "Hello, world!\n" . "Goodbye, world!" ); $textviewer->focus(); =head1 DESCRIPTION Curses::UI::TextViewer is a widget that can be used to create a textviewer widget. This class is derived from Curses::UI::TextEditor. The only special thing about this class is that the B<-readonly> option is forced to a true value. So for the usage of Curses::UI::TextViewer see L. =head1 SEE ALSO L, L, =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Buttonbox.pm0000644000175000001440000004212111627564365017150 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Buttonbox # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Buttonbox; use strict; use Curses; use Curses::UI::Widget; use Curses::UI::Common; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Widget Curses::UI::Common ); # Definition of the most common buttons. my %buttondef = ( 'ok' => { -label => '< OK >', -value => 1, -onpress => undef, -shortcut => 'o', }, 'cancel'=> { -label => '< Cancel >', -value => 0, -onpress => undef, -shortcut => 'c', }, 'yes' => { -label => '< yes >', -value => 1, -onpress => undef, -shortcut => 'y', }, 'no' => { -label => '< No >', -value => 0, -onpress => undef, -shortcut => 'n', }, ); # The default button to use if no buttons were defined. my $default_btn = [ 'ok' ]; my %routines = ( 'press-button' => \&press_button, 'loose-focus' => \&loose_focus, 'next' => \&next_button, 'previous' => \&previous_button, 'shortcut' => \&shortcut, 'focus-shift' => \&focus_shift, 'mouse-button1'=> \&mouse_button1, ); my %bindings = ( CUI_TAB() => 'focus-shift', KEY_BTAB() => 'focus-shift', KEY_ENTER() => 'press-button', CUI_SPACE() => 'press-button', KEY_UP() => 'previous', "k" => 'previous', KEY_DOWN() => 'next', "j" => 'next', KEY_LEFT() => 'previous', 'h' => 'previous', KEY_RIGHT() => 'next', 'l' => 'next', '' => 'shortcut', ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -parent => undef, # the parent window -buttons => $default_btn, # buttons (arrayref) -buttonalignment => undef, # left / middle / right -selected => 0, # which selected -width => undef, # the width of the buttons widget -x => 0, # the horizontal pos rel. to parent -y => 0, # the vertical pos rel. to parent -bg => -1, -fg => -1, %userargs, -routines => {%routines}, -bindings => {%bindings}, -focus => 0, # init value -nocursor => 1, # this widget does not use a cursor ); # The windowscr height should be 1. my $height = $args{-vertical} ? scalar @{$args{-buttons}} : 1; $args{-height} = height_by_windowscrheight($height ,%args); # Create the widget. my $this = $class->SUPER::new( %args ); # Process button definitions. $this->process_buttondefs; $this->layout(); if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding('mouse-button1', BUTTON1_CLICKED()); } return $this; } sub process_buttondefs() { my $this = shift; my $buttons = $this->{-buttons}; # Process button types. my @buttons = (); foreach my $button (@$buttons) { if (ref $button eq 'HASH') { # noop, this is a completed button definition } elsif (not ref $button) { my $realbutton = $buttondef{$button}; unless (defined $realbutton) { $this->root->fatalerror( "process_buttondefs(): Invalid button type.\n" . "No definition found for '$button'" ); } # Check for language support. my $lang_spec = $this->root->lang->get("button_$button"); if ($lang_spec) { my ($shortcut, $label) = split /\:/, $lang_spec, 2; $realbutton->{-label} = "< $label >"; $realbutton->{-shortcut} = $shortcut; } $button = $realbutton; } else { $this->root->fatalerror( "Invalid button definition.\n" . "It should be a HASH reference,\n" . "but is a " . (ref $button) . " reference." ); } keys_to_lowercase($button); push @buttons, $button; } $this->{-buttons} = \@buttons; return $this; } sub layout() { my $this = shift; $this->SUPER::layout() or return; # Compute the space that is needed for the buttons. my $xneed = $this->compute_buttonwidth; my $yneed = $this->compute_buttonheight; if ( ($xneed > $this->canvaswidth) || ($yneed > $this->canvasheight) ) { $Curses::UI::screen_too_small++; return $this; } # Compute the x location of the buttons. my $xpos = 0; if (defined $this->{-buttonalignment}) { if ($this->{-buttonalignment} eq 'right') { $xpos = $this->canvaswidth - $xneed; } elsif ($this->{-buttonalignment} eq 'middle') { $xpos = int (($this->canvaswidth-$xneed)/2); } } $this->{-xpos} = $xpos; $this->{-max_selected} = @{$this->{-buttons}} - 1; # Make shortcuts all upper-case. foreach my $button (@{$this->{-buttons}}) { if (defined $button->{-shortcut}) { $button->{-shortcut} = uc $button->{-shortcut}; } } return $this; } sub get_selected_button() { my $this = shift; my $selected = $this->{-selected}; my $button = $this->{-buttons}->[$selected]; return $button; } sub get() { my $this = shift; my $button = $this->get_selected_button; if (defined $button->{-value}) { return $button->{-value}; } else { return $this->{-selected}; } } sub next_button() { my $this = shift; $this->{-selected}++; $this->schedule_draw(1); return $this; } sub previous_button() { my $this = shift; $this->{-selected}--; $this->schedule_draw(1); return $this; } # Focus the next button. If the last button was # selected, let the buttonbox loose focus. sub focus_shift() { my $this = shift; my $key = shift; if ( $key eq KEY_BTAB() ) { $this->previous_button(); if ($this->{-selected} < 0) { # $this->schedule_draw(0); $this->{-selected} = $this->{-max_selected}; $this->do_routine('loose-focus', $key); } } else { $this->next_button(); if ($this->{-selected} > $this->{-max_selected}) { # $this->schedule_draw(0); $this->{-selected} = 0; $this->do_routine('loose-focus', $key); } } return $this; } sub press_button() { my $this = shift; my $button = $this->get_selected_button; my $command = $button->{-onpress}; $this->schedule_draw(1); if (defined $command and ref $command eq 'CODE') { $command->($this); } return $this; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the widget. $this->SUPER::draw(1) or return $this; # Check if active element isn't out of bounds. $this->{-selected} = 0 unless defined $this->{-selected}; $this->{-selected} = 0 if $this->{-selected} < 0; $this->{-selected} = $this->{-max_selected} if $this->{-selected} > $this->{-max_selected}; # Draw the buttons. my $id = 0; my $x = 0; my $y = 0; my $cursor_x = 0; foreach my $button (@{$this->{-buttons}}) { # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } # Make the focused button reverse. if ($this->{-focus} and defined $this->{-selected} and $id == $this->{-selected}) { $this->{-canvasscr}->attron(A_REVERSE); } # Draw the button. $this->{-canvasscr}->addstr( $y, $this->{-xpos} + $x, $button->{-label} ); # Draw shortcut if available. my $sc = $button->{-shortcut}; if (defined $sc) { my $pos = index(uc $button->{-label}, $sc); if ($pos >= 0) { my $letter = substr($button->{-label}, $pos, 1); $this->{-canvasscr}->attron(A_UNDERLINE); $this->{-canvasscr}->addch( $y, $this->{-xpos} + $x + $pos, $letter ); $this->{-canvasscr}->attroff(A_UNDERLINE); } } # Change the $y value if the buttons are to be drawn vertically and leave $x alone if ( (defined $this->{-vertical}) && ($this->{-vertical}) ) { $y++; } else { $x += 1 + length($button->{-label}); } $this->{-canvasscr}->attroff(A_REVERSE) if $this->{-focus}; $id++; } $this->{-canvasscr}->move(0,0); $this->{-canvasscr}->noutrefresh; doupdate() unless $no_doupdate; return $this; } sub mouse_button1($$$$;) { my $this = shift; my $event = shift; my $x = shift; my $y = shift; my $idx = 0; my $bx = $this->{-xpos}; # Clicked left of the buttons? return $this if $x < $bx; # Find the button on which was clicked. foreach my $button (@{$this->{-buttons}}) { $bx += length($button->{-label}); if ($bx > $x) { last } if ($bx == $x) { $idx = undef; last } $bx += 1; $idx++; } undef $idx if defined $idx and $idx > (@{$this->{-buttons}} - 1); if (defined $idx) { $this->{-selected} = $idx; $this->focus(); $this->do_routine('press-button', $event); } } sub compute_buttonheight($;) { my $this = shift; my $height = 1; if ( (defined $this->{-vertical}) && ($this->{-vertical}) ) { $height = scalar @{$this->{-buttons}}; } return $height; } sub compute_buttonwidth($;) { my $this = shift; $this->process_buttondefs; my $width=0; if ( (defined $this->{-vertical}) && ($this->{-vertical}) ) { foreach my $button (@{$this->{-buttons}}) { if ($width < length($button->{-label})) { $width = length($button->{-label}); } } } else { # Spaces $width = @{$this->{-buttons}} - 1; # Buttons foreach my $button (@{$this->{-buttons}}) { $width += length($button->{-label}); } } return $width; } sub shortcut() { my $this = shift; my $key = uc shift; # Walk through shortcuts to see if the pressed key # is in the list of -shortcuts. my $idx = 0; my $found_idx; SHORTCUT: foreach my $button (@{$this->{-buttons}}) { my $sc = $button->{-shortcut}; if (defined $sc and $sc eq $key) { $found_idx = $idx; last SHORTCUT; } $idx++; } # Shortcut found? if (defined $found_idx) { $this->{-selected} = $found_idx; return $this->process_bindings(KEY_ENTER()); } return $this; } 1; =pod =head1 NAME Curses::UI::Buttonbox - Create and manipulate button widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Buttonbox =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $buttons = $win->add( 'mybuttons', 'Buttonbox', -buttons => [ { -label => '< Button 1 >', -value => 1, -shortcut => 1 },{ -label => '< Button 2 >', -value => 2, -shortcut => 2 } ] ); $buttons->focus(); my $value = $buttons->get(); =head1 DESCRIPTION Curses::UI::Buttonbox is a widget that can be used to create an array of buttons (or, of course, only one button). =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-buttons> < ARRAYREF > This option takes a reference to a list of buttons. The list may contain both predefined button types and complete button definitions of your own. * B A button definition is a reference to a hash. This hash can have the following key-value pairs: obligatory: ----------- -label This determines what text should be drawn on the button. optional: --------- -value This determines the returnvalue for the get() method. If the value is not defined, the get() method will return the index of the button. -shortcut The button will act as if it was pressed if the key defined by -shortcut is pressed -onpress If the value for -onpress is a CODE reference, this code will be executes if the button is pressed, before the buttons widget loses focus and returns. * B This module has a predefined list of frequently used button types. Using these in B<-buttons> makes things a lot easier. The predefined button types are: ok -label => '< OK >' -shortcut => 'o' -value => 1 -onpress => undef cancel -label => '< Cancel >' -shortcut => 'c' -value => 0 -onpress => undef yes -label => '< Yes >' -shortcut => 'y' -value => 1 -onpress => undef no -label => '< No >' -shortcut => 'n' -value => 0 -onpress => undef Example: .... -buttons => [ { -label => '< My own button >', -value => 'mine!', -shortcut => 'm' }, 'ok', 'cancel', { -label => '< My second button >', -value => 'another one', -shortcut => 's', -onpress => sub { die "Do not press this button!\n" } } ] .... =item * B<-selected> < INDEX > By default the first button (index = 0) is active. If you want another button to be active at creation time, add this option. The INDEX is the index of the button you want to make active. =item * B<-buttonalignment> < VALUE > You can specify how the buttons should be aligned in the widget. Available values for VALUE are 'left', 'middle' and 'right'. =item * B<-vertical> < BOOLEAN > When set to a true value, it will cause the buttons to be rendered with vertical instead of horizontal alignment. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the index of the currently active button. If a value is given for that index (using the B<-value> option, see B<-buttons> above), that value will be returned. =back =head1 DEFAULT BINDINGS =over 4 =item * >, > TODO: Fix dox Call the 'loose-focus' routine. By default this routine will have the container in which the widget is loose its focus. If you do not like this behaviour, then you can have it loose focus itself by calling: $buttonswidget->set_routine('loose-focus', 'RETURN'); For an explanation of B, see L. =item * >, > Call the 'previous' routine. This will make the previous button the active button. If the active button already is the first button, nothing will be done. =item * >, Call the 'next' routine. This will make the next button the active button. If the next button already is the last button, nothing will be done. =item * > This will call the 'shortcut' routine. This routine will handle the shortcuts that are set by the B<-shortcuts> option. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Label.pm0000644000175000001440000002366511627564365016217 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Label # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::Label; use strict; use Curses; use Curses::UI::Widget; use Curses::UI::Common; use vars qw( $VERSION @ISA ); $VERSION = '1.11'; @ISA = qw( Curses::UI::Widget ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -parent => undef, # the parent window -width => undef, # the width of the label -height => undef, # the height of the label -x => 0, # the hor. pos. rel. to the parent -y => 0, # the vert. pos. rel. to the parent -text => undef, # the text to show -textalignment => undef, # left / middle / right -bold => 0, # Special attributes -reverse => 0, -underline => 0, -dim => 0, -blink => 0, -paddingspaces => 0, # Pad text with spaces? -bg => -1, -fg => -1, %userargs, -nocursor => 1, # This widget uses no cursor -focusable => 0, # This widget can't be focused ); # Get the text dimension if -width or -height is undefined. my @text_dimension = (undef,1); unless (defined $args{-width} and defined $args{-height}) { @text_dimension = text_dimension($args{-text}) if defined $args{-text}; } # If the -height is not set, determine the height # using the initial contents of the -text. if (not defined $args{-height}) { my $l = $text_dimension[1]; $l = 1 if $l <= 0; $args{-height} = height_by_windowscrheight($l, %args); } # No width given? Then make the width the same size # as the text. No initial text? Then let # Curses::UI::Widget figure it out. $args{-width} = width_by_windowscrwidth($text_dimension[0], %args) unless defined $args{-width} or not defined $args{-text}; # If no text was defined (how silly...) we define an empty string. $args{-text} = '' unless defined $args{-text}; # Create the widget. my $this = $class->SUPER::new( %args ); $this->layout(); return $this; } sub layout() { my $this = shift; $this->SUPER::layout or return; return $this; } sub bold ($;$) { shift()->set_attribute('-bold', shift()) } sub reverse ($;$) { shift()->set_attribute('-reverse', shift()) } sub underline ($;$) { shift()->set_attribute('-underline', shift()) } sub dim ($;$) { shift()->set_attribute('-dim', shift()) } sub blink ($;$) { shift()->set_attribute('-blink', shift()) } sub set_attribute($$;) { my $this = shift; my $attribute = shift; my $value = shift || 0; $this->{$attribute} = $value; $this->intellidraw; return $this; } sub text($;$) { my $this = shift; my $text = shift; if (defined $text) { $this->{-text} = $text; $this->intellidraw; return $this; } else { return $this->{-text}; } } sub get() { shift()->text } sub textalignment($;) { my $this = shift; my $value = shift; $this->{-textalignment} = $value; $this->intellidraw; return $this; } sub compute_xpos() { my $this = shift; my $line = shift; # Compute the x location of the text. my $xpos = 0; if (defined $this->{-textalignment}) { if ($this->{-textalignment} eq 'right') { $xpos = $this->canvaswidth - length($line); } elsif ($this->{-textalignment} eq 'middle') { $xpos = int (($this->canvaswidth-length($line))/2); } } $xpos = 0 if $xpos < 0; return $xpos; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the widget. $this->SUPER::draw(1) or return $this; # Clear all attributes. $this->{-canvasscr}->attroff(A_REVERSE); $this->{-canvasscr}->attroff(A_BOLD); $this->{-canvasscr}->attroff(A_UNDERLINE); $this->{-canvasscr}->attroff(A_BLINK); $this->{-canvasscr}->attroff(A_DIM); # Set wanted attributes. $this->{-canvasscr}->attron(A_REVERSE) if $this->{-reverse}; $this->{-canvasscr}->attron(A_BOLD) if $this->{-bold}; $this->{-canvasscr}->attron(A_UNDERLINE) if $this->{-underline}; $this->{-canvasscr}->attron(A_BLINK) if $this->{-blink}; $this->{-canvasscr}->attron(A_DIM) if $this->{-dim}; # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } # Draw the text. Clip it if it is too long. my $ypos = 0; my $split = split_to_lines($this->{-text}); foreach my $line (@$split) { if (length($line) > $this->canvaswidth) { # Break text $line = substr($line, 0, $this->canvaswidth); $line =~ s/.$/\$/; } elsif ($this->{-paddingspaces}) { $this->{-canvasscr}->addstr($ypos, 0, " "x$this->canvaswidth); } my $xpos = $this->compute_xpos($line); $this->{-canvasscr}->addstr($ypos, $xpos, $line); $ypos++; } $this->{-canvasscr}->noutrefresh; doupdate() unless $no_doupdate; return $this; } 1; =pod =head1 NAME Curses::UI::Label - Create and manipulate label widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Label =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $label = $win->add( 'mylabel', 'Label', -text => 'Hello, world!', -bold => 1, ); $label->draw; =head1 DESCRIPTION Curses::UI::Label is a widget that shows a textstring. This textstring can be drawn using these special features: bold, dimmed, reverse, underlined, and blinking. See exampes/demo-Curses::UI::Label in the distribution for a short demo. =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-height> < VALUE > If you do not define B<-height>, the label will compute its needed height using the initial B<-text>. =item * B<-text> < TEXT > This will set the text on the label to TEXT. =item * B<-textalignment> < VALUE > This option controls how the text should be aligned inside the label. VALUE can be 'left', 'middle' and 'right'. The default value for this option is 'left'. =item * B<-paddingspaces> < BOOLEAN > This option controls if padding spaces should be added to the text if the text does not fill the complete width of the widget. The default value for BOOLEAN is false. An example use of this option is: $win->add( 'label', 'Label', -width => -1, -paddingspaces => 1, -text => 'A bit of text', ); This will create a label that fills the complete width of your screen and which will be completely in reverse font (also the part that has no text on it). See the demo in the distribution (examples/demo-Curses::UI::Label) for a clear example of this) =item * B<-bold> < BOOLEAN > If BOOLEAN is true, text on the label will be drawn in a bold font. =item * B<-dim> < BOOLEAN > If BOOLEAN is true, text on the label will be drawn in a dim font. =item * B<-reverse> < BOOLEAN > If BOOLEAN is true, text on the label will be drawn in a reverse font. =item * B<-underline> < BOOLEAN > If BOOLEAN is true, text on the label will be drawn in an underlined font. =item * B<-blink> < BOOLEAN > If BOOLEAN is option is true, text on the label will be drawn in a blinking font. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) These are standard methods. See L for an explanation of these. =item * B ( BOOLEAN ) =item * B ( BOOLEAN ) =item * B ( BOOLEAN ) =item * B ( BOOLEAN ) =item * B ( BOOLEAN ) These methods can be used to control the font in which the text on the label is drawn, after creating the widget. The font option will be turned on for a true value of BOOLEAN. =item * B ( VALUE ) Set the textalignment. VALUE can be 'left', 'middle' or 'right'. =item * B ( [TEXT] ) Without the TEXT argument, this method will return the current text of the widget. With a TEXT argument, the text on the widget will be set to TEXT. =item * B ( ) This will call the B method without any argument and thus it will return the current text of the label. =back =head1 DEFAULT BINDINGS Since a Label is a non-interacting widget, it does not have any bindings. =head1 SEE ALSO L, L, =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Radiobuttonbox.pm0000644000175000001440000000551011627564365020170 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Radiobuttonbox # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::Radiobuttonbox; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Listbox; use Curses::UI::Widget; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Listbox ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( %userargs, -radio => 1, # Force radiobuttons -multi => 0, # Force no multiselect ); # Compute the needed with if -width is undefined. # The extra 4 positions are for the radiobutton drawing. $args{-width} = 4 + width_by_windowscrwidth(maxlabelwidth(%args), %args) unless defined $args{-width}; # Create the entry. my $this = $class->SUPER::new( %args); return $this; } 1; =pod =head1 NAME Curses::UI::Radiobuttonbox - Create and manipulate radiobuttonbox widgets =head1 CLASS HIERARCHY Curses::UI::Widget Curses::UI::Searchable | +----Curses::UI::Listbox | +----Curses::UI::Radiobuttonbox =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $radiobuttonbox = $win->add( 'myradiobuttonbox', 'Radiobuttonbox', -values => [1, 2, 3], -labels => { 1 => 'One', 2 => 'Two', 3 => 'Three' }, ); $radiobuttonbox->focus(); my $selected = $radiobuttonbox->get(); =head1 DESCRIPTION Curses::UI::Radiobuttonbox is a widget that can be used to create a radiobutton listbox. Only one value can be selected at a time. This kind of listbox looks somewhat like this: +----------+ |< > One | | Two | |< > Three | +----------+ A Radiobuttonbox is derived from Curses::UI::Listbox. The only special thing about this class is that the B<-radio> option is forced to a true value. So for the usage of Curses::UI::Radiobuttonbox see L). =head1 SEE ALSO L, L, =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Language.pm0000644000175000001440000000712111627564365016710 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Language # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Language; my $default_lang = 'English'; my %lang_alias = ( 'en' => 'english', 'uk' => 'english', 'us' => 'english', 'it' => 'italian', 'pl' => 'polish', 'ru' => 'russian', 'de' => 'german', 'at' => 'german', 'ch' => 'german', 'du' => 'dutch', 'nl' => 'dutch', 'fr' => 'french', 'pt' => 'portuguese', 'pt_BR' => 'portuguese', 'br' => 'portuguese', 'no' => 'norwegian', 'es' => 'spanish', 'tr' => 'tukish', 'cn' => 'chinese', ); sub new() { my $class = shift; my $lang = shift; my $this = { -tags => {}, -lang => undef, }; bless $this, $class; # Load english tags so these can be used # as a fallback for other languages. $this->loadlanguage('english'); # Load the wanted language. $this->loadlanguage($lang); return $this; } sub loadlanguage($;) { my $this = shift; my $lang = shift; # Construct the language module to use. $lang = $default_lang unless defined $lang; $lang =~ s/[^\w\_]//g; $lang = lc $lang; $lang = $lang_alias{$lang} if defined $lang_alias{$lang}; # Loading the same language twice is not very useful. return $this if defined $this->{-lang} and $lang eq $this->{-lang}; # Determine filename for the language package. (my $l_file = __FILE__) =~ s/\.pm$/\/$lang\.pm/; # Save the name of the currently loaded language. $this->{-lang} = $lang; # Create a filehandle to the __DATA__ section # of the language package. local *LANG_DATA; open(LANG_DATA, "< $l_file") or die "Can't open $l_file: $!"; while () { last if /^\s*__DATA__$/; } # Read and store tags/blocks. my $tag = undef; my $block = ''; LINE: while () { if (m/^#/) { next LINE; } elsif (m/^\s*\[\s*(.*)\s*\]\s*(.*)$/) { my $oldtag = $tag; $tag = $1; $this->store($oldtag, $block); $block = $2; $block = '' unless defined $block; } elsif (defined $tag) { $block .= "$_"; } elsif (!m/^\s*$/) { warn "$l_file, line $.: found data outside tag block\n"; } } $this->store($tag, $block); close(LANG_DATA); } sub store($$;) { my $this = shift; my $tag = shift; my $block = shift; return $this unless defined $tag; # Remove empty start- and endlines. my @block = split /\n/, $block; while (@block and $block[0] =~ /^\s*$/) { shift @block } while (@block and $block[-1] =~ /^\s*$/) { pop @block } $this->{-tags}->{lc $tag} = join "\n", @block; return $this; } sub get($;) { my $this = shift; my $tag = shift; my $block = $this->{-tags}->{$tag}; unless (defined $block) { warn "get(): no language block for tag '$tag'"; $block = ''; } return $block; } sub getarray($;) { my $this = shift; my $tag = shift; my $block = $this->get($tag); return () unless defined $block; $block =~ s/\n/ /g; return split " ", $block; } 1; Curses-UI-0.9609/lib/Curses/UI/Checkbox.pm0000644000175000001440000001702711627564365016721 0ustar mdxiuserspackage Curses::UI::Checkbox; use strict; use Curses; use Curses::UI::Label; use Curses::UI::Widget; use Curses::UI::Common; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::ContainerWidget ); =head1 NAME Curses::UI::Checkbox - Create and manipulate checkbox widgets =head1 VERSION Version 1.11 =cut $VERSION = '1.11'; =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Checkbox =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $checkbox = $win->add( 'mycheckbox', 'Checkbox', -label => 'Say hello to the world', -checked => 1, ); $checkbox->focus(); my $checked = $checkbox->get(); =head1 DESCRIPTION Curses::UI::Checkbox provides a checkbox widget. A checkbox is a control for a boolean value (an on/off toggle). It consists of a box which will either be empty (indicating B or B) or contain an C (indicating B or B). Following this is a text label which described the value being controlled. [X] This checkbox is on/true/checked/selected [ ] This checkbox is off/false/unchecked/deselected See exampes/demo-Curses::UI::Checkbox in the distribution for a short demo. =cut my %routines = ( 'loose-focus' => \&loose_focus, 'uncheck' => \&uncheck, 'check' => \&check, 'toggle' => \&toggle, 'mouse-button1' => \&mouse_button1, ); my %bindings = ( KEY_ENTER() => 'loose-focus', CUI_TAB() => 'loose-focus', KEY_BTAB() => 'loose-focus', CUI_SPACE() => 'toggle', '0' => 'uncheck', 'n' => 'uncheck', '1' => 'check', 'y' => 'check', ); =head1 STANDARD OPTIONS -x -y -width -height -pad -padleft -padright -padtop -padbottom -ipad -ipadleft -ipadright -ipadtop -ipadbottom -title -titlefullwidth -titlereverse -onfocus -onblur -parent See L for an explanation of these. =head1 WIDGET-SPECIFIC OPTIONS =head2 -label Sets the initial label for the checkbox widget to the passed string or value. =head2 -checked Takes a boolean argument. Determines if the widget's initial state is checked or unchecked. The default is false (unchecked). =head2 -onchange Expects a coderef and sets it as a callback for the widget. When the checkbox's state is changed, the given code will be executed. =cut sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -parent => undef, # the parent window -width => undef, # the width of the checkbox -x => 0, # the horizontal pos. rel. to parent -y => 0, # the vertical pos. rel. to parent -checked => 0, # checked or not? -label => '', # the label text -onchange => undef, # event handler -bg => -1, -fg => -1, %userargs, -bindings => {%bindings}, -routines => {%routines}, -focus => 0, # value init -nocursor => 0, # this widget uses a cursor ); # The windowscr height should be 1. $args{-height} = height_by_windowscrheight(1, %args); # No width given? Then make the width the same size as the label + # checkbox. $args{-width} = width_by_windowscrwidth(4 + length($args{-label}),%args) unless defined $args{-width}; my $this = $class->SUPER::new( %args ); # Create the label on the widget. $this->add( 'label', 'Label', -text => $this->{-label}, -x => 4, -y => 0, -intellidraw => 0, -bg => $this->{-bg}, -fg => $this->{-fg}, ) if $this->{-label}; $this->layout; $this->set_mouse_binding('mouse-button1', BUTTON1_CLICKED()) if ($Curses::UI::ncurses_mouse); return $this; } =head1 STANDARD METHODS layout draw intellidraw focus onFocus onBlur See L for an explanation of these. =cut sub event_onblur() { my $this = shift; $this->SUPER::event_onblur; $this->{-focus} = 0; $this->draw(); return $this; } sub layout() { my $this = shift; my $label = $this->getobj('label'); if (defined $label) { my $lh = $label->{-height}; $lh = 1 if $lh <= 0; $this->{-height} = $lh; } $this->SUPER::layout or return; return $this; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the widget. $this->SUPER::draw(1) or return $this; # Draw the checkbox. if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } $this->{-canvasscr}->attron(A_BOLD) if $this->{-focus}; $this->{-canvasscr}->addstr(0, 0, '[ ]'); $this->{-canvasscr}->addstr(0, 1, 'X') if $this->{-checked}; $this->{-canvasscr}->attroff(A_BOLD) if $this->{-focus}; $this->{-canvasscr}->move(0,1); $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } =head1 WIDGET-SPECIFIC METHODS =head2 get Returns the current state of the checkbox (0 == unchecked, 1 == checked). =cut sub get() { my $this = shift; return $this->{-checked}; } =head2 check Sets the checkbox to "checked". =cut sub check() { my $this = shift; my $changed = ($this->{-checked} ? 0 : 1); $this->{-checked} = 1; if ($changed) { $this->run_event('-onchange'); $this->schedule_draw(1); } return $this; } =head2 uncheck Sets the checkbox to "unchecked". =cut sub uncheck() { my $this = shift; my $changed = ($this->{-checked} ? 1 : 0); $this->{-checked} = 0; if ($changed) { $this->run_event('-onchange'); $this->schedule_draw(1); } return $this; } =head2 toggle Flip-flops the checkbox to its "other" state. If the checkbox is unchecked then it will become checked, and vice versa. =cut sub toggle() { my $this = shift; $this->{-checked} = ($this->{-checked} ? 0 : 1); $this->run_event('-onchange'); $this->schedule_draw(1); } =head2 onChange This method can be used to set the C<-onchange> event handler (see above) after initialization of the checkbox. It expects a coderef as its argument. =cut sub onChange(;$) { shift()->set_event('-onchange', shift()) } sub mouse_button1($$$$;) { my $this = shift; my $event = shift; my $x = shift; my $y = shift; $this->focus(); $this->toggle(); return $this; } =head1 DEFAULT BINDINGS =over =item C<[TAB]>, C<[ENTER}> Call the 'loose-focus' routine, causing the widget to lose focus. =item C<[SPACE]> Call the L method. =item C<0>, C Call the L method. =item C<1>, C Call the L method. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Shawn Boyette C<< >> =head1 COPYRIGHT & LICENSE Copyright 2001-2002 Maurice Makaay; 2003-2006 Marcus Thiesen; 2007 Shawn Boyette. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. =cut 1; # end of Curses::UI::Checkbox Curses-UI-0.9609/lib/Curses/UI/Calendar.pm0000644000175000001440000005214211627564365016701 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Calendar # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- #TODO: fix dox package Curses::UI::Calendar; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Widget; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Widget Curses::UI::Common ); my @days = (); my @months = (); my %routines = ( 'loose-focus' => \&loose_focus, 'date-select' => \&date_select, 'date-selected' => \&date_selected, 'date-nextday' => \&date_nextday, 'date-prevday' => \&date_prevday, 'date-nextweek' => \&date_nextweek, 'date-prevweek' => \&date_prevweek, 'date-nextmonth' => \&date_nextmonth, 'date-prevmonth' => \&date_prevmonth, 'date-nextyear' => \&date_nextyear, 'date-prevyear' => \&date_prevyear, 'date-today' => \&date_today, 'mouse-button' => \&mouse_button, ); my %bindings = ( CUI_TAB() => 'loose-focus', KEY_BTAB() => 'loose-focus', KEY_LEFT() => 'date-prevday', "h" => 'date-prevday', KEY_RIGHT() => 'date-nextday', "l" => 'date-nextday', KEY_DOWN() => 'date-nextweek', "j" => 'date-nextweek', KEY_UP() => 'date-prevweek', "k" => 'date-prevweek', KEY_NPAGE() => 'date-nextmonth', "J", => 'date-nextmonth', KEY_PPAGE() => 'date-prevmonth', "K", => 'date-prevmonth', "L", => 'date-nextyear', "H", => 'date-prevyear', "n", => 'date-nextyear', "p", => 'date-prevyear', KEY_HOME() => 'date-selected', "\cA" => 'date-selected', "c" => 'date-selected', "t" => 'date-today', KEY_ENTER() => 'date-select', CUI_SPACE() => 'date-select', ); # ---------------------------------------------------------------------- # Constructor # ---------------------------------------------------------------------- sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -date => undef, # The date to start width -width => 0, # Widget will fix width itself -height => 0, # Widget will fix height itself -onchange => undef, # Event handler -fg => -1, -bg => -1, -drawline => 1, # Draw a line under the widget? %userargs, -routines => {%routines}, -bindings => {%bindings}, -ipadleft => 1, -ipadright => 1, -ipadbottom => 0, -ipadtop => 0, -focus => 0, -nocursor => 1, ); # The widget width should be at least 20. my $min_width = width_by_windowscrwidth(20, %args); $args{-width} = $min_width if $args{-width} != -1 and $args{-width} < $min_width; # The widget height should be at least 11. my $min_height = height_by_windowscrheight(11, %args); $args{-height} = $min_height if $args{-height} != -1 and $args{-height} < $min_height; my $this = $class->SUPER::new( %args ); # Split up and fix the date. $this->setdate($this->{-date}, 1); # Set cursor to current date. $this->{-cyear} = $this->{-year}; $this->{-cmonth} = $this->{-month}; $this->{-cday} = $this->{-day}; # Load day- and monthnames. @days = $this->root->lang->getarray('days_short'); @months = (undef, $this->root->lang->getarray('months')); if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding( 'mouse-button', BUTTON1_CLICKED(), BUTTON3_CLICKED()); } return $this; } # ---------------------------------------------------------------------- # Methods # ---------------------------------------------------------------------- sub onChange(;$) { shift()->set_event('-onchange', shift()) } sub day($;) { shift()->accessor('-day', shift()) } sub month($;) { shift()->accessor('-month', shift()) } sub year($;) { shift()->accessor('-year', shift()) } sub layout() { my $this = shift; $this->SUPER::layout() or return; return $this; } sub setdate($;$) { my $this = shift; my $date = shift; my $nodraw = shift || 0; if (not defined $date) { $this->{-year} = undef; $this->{-month} = undef; $this->{-day} = undef; } elsif ($date =~ /^(\d\d\d\d+)(\d\d)(\d\d)$/) { $this->{-year} = $1; $this->{-month} = $2; $this->{-day} = $3; } elsif ($date =~ /^(\d{1,2})\D(\d{1,2})\D(\d\d\d\d+)$/) { $this->{-year} = $3; $this->{-month} = $2; $this->{-day} = $1; } elsif ($date =~ /^(\d\d\d\d+)\D(\d{1,2})\D(\d{1,2})$/) { $this->{-year} = $1; $this->{-month} = $2; $this->{-day} = $3; } $this->make_sane_date; $this->intellidraw unless $nodraw; return $this; } sub make_sane_date() { my $this = shift; my $cursor = shift; my $c = $cursor ? 'c' : ''; # Determine 'today'. my @now = localtime(); $now[4]++; $now[5]+=1900; # Use today's values if undefined. $this->{"-${c}day"} = $now[3] unless defined $this->{"-${c}day"}; $this->{"-${c}month"} = $now[4] unless defined $this->{"-${c}month"}; $this->{"-${c}year"} = $now[5] unless defined $this->{"-${c}year"}; if ($this->{"-${c}year"} < 0) { $this->{"-${c}year"} = 0 } if ($this->{"-${c}year"} > 9999) { $this->{"-${c}year"} = 9999 } if ($this->{"-${c}month"} < 1) { $this->{"-${c}month"} = 1 } if ($this->{"-${c}month"} > 12) { $this->{"-${c}month"} = 12 } my $days = days_in_month($this->{"-${c}year"}, $this->{"-${c}month"}); if ($this->{"-${c}day"} < 1) { $this->{"-${c}day"} = 1 } if ($this->{"-${c}day"} > $days) { $this->{"-${c}day"} = $days } # undef value? if ($this->{"-${c}year"} == 1752 and $this->{"-${c}month"} == 9) { if ($this->{"-${c}day"} > 2 and $this->{"-${c}day"} < 14) { $this->{"-${c}day"} = ($this->{"-${c}day"} > 8 ? 14 : 2); } } return $this; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the widget $this->SUPER::draw(1) or return $this; $this->make_sane_date; $this->make_sane_date(1); # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } # Bold font on if the widget has focus and the selected # date is the active date. $this->{-canvasscr}->attron(A_BOLD) if $this->{-focus} and $this->{-cyear} == $this->{-year} and $this->{-cmonth} == $this->{-month} and $this->{-cday} == $this->{-day}; # Draw day, month and year. If the widget has focus, # show the cursor position. Else show the selected position. my $c = $this->{-focus} ? 'c' : ''; $this->{-canvasscr}->addstr(0,0," "x$this->canvaswidth); $this->{-canvasscr}->addstr(0,0, $months[$this->{"-${c}month"}] . " " . $this->{"-${c}day"}); $this->{-canvasscr}->addstr(0,$this->canvaswidth-4,$this->{"-${c}year"}); # Draw daynames $this->{-canvasscr}->attron(A_BOLD) if $this->{-focus}; $this->{-canvasscr}->addstr(2,0,join " ", @days); # Reset bold font attribute. $this->{-canvasscr}->attroff(A_BOLD) if $this->{-focus}; # Draw a line under the date. if ($this->{-drawline}) { $this->{-canvasscr}->move(1,0); $this->{-canvasscr}->hline(ACS_HLINE,$this->canvaswidth); } # Create the list of days in the current month. my @month = build_month($this->{"-${c}year"}, $this->{"-${c}month"}); # Draw the days. my $month = $this->{"-${c}month"}; my $year = $this->{"-${c}year"}; my $y = 4; my $weekday = 0; foreach my $day (@month) { unless (defined $day) { $weekday++; next; } # Make current date bold. $this->{-canvasscr}->attron(A_BOLD) if $this->{-day} == $day and $this->{-month} == $month and $this->{-year} == $year; # Make selected date inverse if widget has focus. $this->{-canvasscr}->attron(A_REVERSE) if $this->{-focus} and $this->{-cday} == $day and $this->{-cmonth} == $month and $this->{-cyear} == $year; # Draw the day. $this->{-canvasscr}->addstr($y, $weekday*3, sprintf("%2d",$day)); # Reset attributes. $this->{-canvasscr}->attroff(A_REVERSE); $this->{-canvasscr}->attroff(A_BOLD); $weekday++; if ($weekday == 7) { $weekday = 0; $y++; } } # Move the cursor to the bottomright corner of the widget # (in case the terminal does not support widget hiding). $this->{-canvasscr}->move($this->canvasheight-1, $this->canvaswidth-1); $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } sub date_selected() { my $this = shift; $this->{-cyear} = $this->{-year}; $this->{-cmonth} = $this->{-month}; $this->{-cday} = $this->{-day}; $this->schedule_draw(1); return $this; } sub date_today() { my $this = shift; $this->{-cmonth} = undef; $this->{-cday} = undef; $this->{-cyear} = undef; $this->schedule_draw(1); return $this; } sub date_prevyear() { my $this = shift; $this->{-cyear}--; $this->{-cyear} = 0 if $this->{-cyear} < 0; $this->schedule_draw(1); return $this; } sub date_nextyear() { my $this = shift; $this->{-cyear}++; $this->{-cyear} = 9999 if $this->{-cyear} > 9999; $this->schedule_draw(1); return $this; } sub date_prevmonth() { my $this = shift; $this->{-cmonth}--; if ($this->{-cmonth} < 1 and $this->{-cyear} > 0) { $this->{-cmonth} = 12; $this->{-cyear}--; } $this->schedule_draw(1); return $this; } sub date_nextmonth() { my $this = shift; $this->{-cmonth}++; if ($this->{-cmonth} > 12 and $this->{-cyear} < 9999) { $this->{-cmonth} = 1; $this->{-cyear}++; } $this->schedule_draw(1); return $this; } sub date_delta_days($;) { my $this = shift; my $delta = shift; if ($delta < 0) { my $startday = $this->{-cday}; $this->{-cday} += $delta; if ($this->{-cday} < 1) { if ( ($this->{-cmonth} >= 1 and $this->{-cyear} >= 1) or ($this->{-cmonth} >= 2 and $this->{-cyear} >= 0) ) { $this->date_prevmonth(); my $days = days_in_month($this->{-cyear}, $this->{-cmonth}); $this->{-cday} = $startday + $delta + $days; } } } else { my $days = days_in_month($this->{-cyear}, $this->{-cmonth}); my $newday = $this->{-cday} + $delta - $days; $this->{-cday} += $delta; if ($this->{-cday} > $days and $this->{-cyear} < 9999) { $this->date_nextmonth(); $this->{-cday} = $newday; } } if ($this->{-cyear} == 1752 and $this->{-cmonth} == 9) { if ($this->{-cday} > 2 and $this->{-cday} < 14) { $this->{-cday} = ($delta > 0 ? 14 : 2); } } $this->schedule_draw(1); } sub date_prevweek() { my $this = shift; $this->date_delta_days(-7); $this->schedule_draw(1); return $this; } sub date_nextweek() { my $this = shift; $this->date_delta_days(+7); $this->schedule_draw(1); return $this; } sub date_prevday() { my $this = shift; $this->date_delta_days(-1); $this->schedule_draw(1); return $this; } sub date_nextday() { my $this = shift; $this->date_delta_days(+1); $this->schedule_draw(1); return $this; } sub date_select() { my $this = shift; $this->{-day} = $this->{-cday}; $this->{-month} = $this->{-cmonth}; $this->{-year} = $this->{-cyear}; $this->schedule_draw(1); $this->run_event('-onchange'); return $this; } sub mouse_button($$$$;) { my $this = shift; my $event = shift; my $x = shift; my $y = shift; # Click in the day area? if ($y > 3 and $y < 10) { my @month = build_month($this->{-cyear}, $this->{-cmonth}); my $weekday = 0; my $ty = 4; foreach my $day (@month) { unless (defined $day) { $weekday++; next } my ($dx, $dy) = ($weekday*3, $ty); if ($x >= $dx and $x < $dx+2 and $y == $dy) { $this->{-cday} = $day; $this->date_select(1); $this->focus(); last; } $weekday++; if ($weekday == 7) { $weekday = 0; $ty++; } } } # Click on the year? elsif ($y == 0 and $x > ($this->canvaswidth-5) and $x < $this->canvaswidth) { # Select year if ( $event->{-bstate} == BUTTON3_CLICKED() ) { $this->date_nextyear; } else { $this->date_prevyear; } $this->focus(); } # Click on the month? elsif ( $y == 0 and $x >= 0 and $x < length($months[$this->{-cmonth}]) ) { if ( $event->{-bstate} == BUTTON3_CLICKED() ) { $this->date_nextmonth; } else { $this->date_prevmonth; } $this->focus(); } return $this; } sub get() { my $this = shift; $this->make_sane_date(); return sprintf("%04d-%02d-%02d", $this->{-year}, $this->{-month}, $this->{-day}); } # ---------------------------------------------------------------------- # Date calculation # ---------------------------------------------------------------------- my @days_in_month = (undef,31,28,31,30,31,30,31,31,30,31,30,31); sub is_julian ($$;) { my ($year, $month) = @_; return $year < 1752 or ($year == 1752 and $month <= 9); } sub day_of_week($$$;) { my $year = shift; my $month = shift; my $day = shift; my $a = int( (14 - $month)/12 ); my $y = $year - $a; my $m = $month + (12 * $a) - 2; my $day_of_week; if (is_julian($year, $month)) { $day_of_week = ( 5 + $day + $y + int($y/4) + int(31*$m/12) ) % 7; } else { $day_of_week = ( $day + $y + int($y/4) - int($y/100) + int($y/400) + int(31*$m/12) ) % 7; } return $day_of_week; } sub days_in_month($$;) { my $year = shift; my $month = shift; if($month == 2 and is_leap_year($year)) { return 29; } else { return $days_in_month[$month]; } } sub is_leap_year($;) { my $year = shift; if (is_julian($year,1)) { return 1 if $year % 4 == 0; } else { return 1 if ($year % 4 == 0 and $year % 100 != 0) or $year % 400 == 0; } return 0; } sub build_month ($$;) { my $year = shift; my $month = shift; my $first_weekday = day_of_week($year, $month, 1); my $number_of_days = days_in_month($year, $month); if ($year == 1752 and $month == 9) { $number_of_days = 19; } my @month = (); for (1..$first_weekday) { push @month, undef; } my $realday = 1; for( my $day = 1; $day <= $number_of_days; $day++ ) { push @month, $realday; if ($year == 1752 and $month == 9 and $realday == 2) { $realday = 13; } $realday++; } return @month; } 1; =pod =head1 NAME Curses::UI::Calendar - Create and manipulate calendar widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Calendar =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $calendar = $win->add( 'mycalendar', 'Calendar', -date => '2002-1-14' ); $calendar->focus(); my $date = $calendar->get(); =head1 DESCRIPTION Curses::UI::Calendar is a widget that can be used to create a calendar in which the user can select a date. The calendar widget looks like this: +----------------------+ | mmm dd yyyy | +----------------------+ | su mo tu we th fr sa | | | | 01 02 03 04 05 | | 06 07 08 09 10 11 12 | | 13 14 15 16 17 18 19 | | 20 21 22 23 24 25 26 | | 27 28 29 30 31 | +----------------------+ See exampes/demo-Curses::UI::Calendar in the distribution for a short demo. =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. B: B<-width> and B<-height> can be set, but this widget really want to have its content space at a minimum size. If your B<-width> or B<-height> is not large enough, the widget will automatically fix its value. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-date> < DATE > This option sets the date to start with. If you do not specify a date, today's date will be used automatically. The format that you can use for this date is one of: * B (e.g. 2002-1-10 or 2002-01-10) * B (e.g. 2002/1/10 or 2002/01/10)) * B (e.g. 20020110) * B (e.g. 10-1-2002 or 10/01/2002) * B (e.g. 10/1/2002 or 10/01/2002) =item * B<-onchange> < CODEREF > This sets the onChange event handler for the calendar widget. If a new date is selected, the code in CODEREF will be executed. It will get the widget reference as its argument. =item * B<-drawline> < CODEREF > This option specifies whether or not a line should be drawn under the calendar. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the currently selected date in the format 'YYYY-MM-DD'. =item * B ( DATE, [BOOLEAN] ) Set the selected date of the widget to DATE. See B<-date> above for the possible formats. The widget will redraw itself, unless BOOLEAN has a true value. =item * B ( CODEREF ) This method can be used to set the B<-onchange> event handler (see above) after initialization of the calendar. =back =head1 DEFAULT BINDINGS =over 4 =item * > Call the 'loose-focus' routine. This will have the menubar loose its focus and return the value 'LOOSE_FOCUS' to the calling routine. =item * >, > Call the 'date-select' routine. This will select the date on which the cursor is. =item * >, > Call the 'date-prevday' routine. This will have the date cursor go back one day. =item * , > Call the 'date-nextday' routine. This will have the date cursor go forward one day. =item * >, > Call the 'date-nextweek' routine. This will have the date cursor go forward one week. =item * >, > Call the 'date-prevweek' routine. This will have the date cursor go back one week. =item * >, > Call the 'date-prevmonth' routine. This will have the date cursor go back one month. =item * >, > Call the 'date-nextmonth' routine. This will have the date cursor go forward one month. =item * >, > Call the 'date-prevyear' routine. This will have the date cursor go back one year. =item * >, > Call the 'date-nextyear' routine. This will have the date cursor go forward one year. =item * >, >, > Call the 'date-selected' routine. This will have the date cursor go to the current selected date. =item * > Call the 'date-today' routine. This will have the date cursor go to today's date. =back =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/TextEntry.pm0000644000175000001440000000562011627564365017135 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::TextEntry # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::TextEntry; use strict; use Curses; use Curses::UI::Common; use Curses::UI::TextEditor; use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::TextEditor ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -undolevels => 20, # number of undolevels. 0 = infinite -homeonblur => 1, # cursor to homepos on blur? -bg => -1, -fg => -1, %userargs, -singleline => 1, # single line mode or not? -showhardreturns => 0, # show hard returns with diamond char? ); # Create the entry. my $this = $class->SUPER::new( %args ); # There is no reason to show overflow symbols if no # more characters than the available width can be # added (the screen would wrap and after that # typing would be impossible). if ($this->{-maxlength} and $this->canvaswidth > $this->{-maxlength}) { $this->{-showoverflow} = 0; } # Setup bindings. $this->clear_binding('loose-focus'); $this->set_binding('loose-focus', KEY_ENTER(), CUI_TAB(), KEY_BTAB() ); return $this; } 1; =pod =head1 NAME Curses::UI::TextEntry - Create and manipulate textentry widgets =head1 CLASS HIERARCHY Curses::UI::Widget Curses::UI::Searchable | +----Curses::UI::TextEditor | +----Curses::UI::TextEntry =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $textentry = $win->add( 'mytextentry', 'TextEntry' ); $textentry->focus(); my $text = $textentry->get(); =head1 DESCRIPTION Curses::UI::TextEntry is a widget that can be used to create a textentry widget. This class is derived from Curses::UI::TextEditor. The only special thing about this class is that the B<-singleline> option is forced to a true value. So for the usage of Curses::UI::TextEntry see L. =head1 SEE ALSO L, L, =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/PasswordEntry.pm0000644000175000001440000000470211627564365020013 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::PasswordEntry # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::PasswordEntry; use strict; use Curses; use Curses::UI::TextEntry; use Curses::UI::Common; use vars qw($VERSION @ISA); @ISA = qw( Curses::UI::TextEntry ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -undolevels => 20, # number of undolevels. 0 = infinite -homeonblur => 1, # cursor to homepos on blur? -fg => -1, -bg => -1, %userargs, -password => '*',# force password token -showhardreturns => 0, ); # Create the entry. my $this = $class->SUPER::new( %args); return $this; } 1; =pod =head1 NAME Curses::UI::PasswordEntry - Create and manipulate passwordentry widgets =head1 CLASS HIERARCHY Curses::UI::Widget Curses::UI::Searchable | +----Curses::UI::TextEditor | +----Curses::UI::TextEntry | +----Curses::UI::PasswordEntry =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $passwordentry = $win->add( 'mypasswordentry', 'PasswordEntry' ); $passwordentry->focus(); my $password = $passwordentry->get(); =head1 DESCRIPTION Curses::UI::PasswordEntry is a widget that can be used to create a passwordentry widget. This class is derived from Curses::UI::TextEntry. The only special thing about this class is that the B<-password> option is forced to '*'. So for the usage of Curses::UI::PasswordEntry see L. =head1 SEE ALSO L, L, =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Popupmenu.pm0000644000175000001440000003215111627564365017156 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Popupmenu # Curses::UI::PopupmenuListbox # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox # ---------------------------------------------------------------------- # Windowable listbox # ---------------------------------------------------------------------- package Curses::UI::PopupmenuListbox; use Curses; use Curses::UI::Listbox; use Curses::UI::Window; use Curses::UI::Common; use vars qw( $VERSION @ISA ); $VERSION = '1.0011'; @ISA = qw( Curses::UI::Listbox Curses::UI::Window ); sub new() { my $class = shift; my $this = $class->SUPER::new(@_); # Do own option_select() method. $this->set_routine('option-select', \&option_select); return $this; } sub option_select() { my $this = shift; $this->SUPER::option_select(); $this->loose_focus; return $this; } # Let Curses::UI->usemodule() believe that this module # was already loaded (usemodule() would else try to # require the non-existing file). # $INC{'Curses/UI/PopupmenuListbox.pm'} = $INC{'Curses/UI/Popupmenu.pm'}; # ---------------------------------------------------------------------- # The Popupmenu # ---------------------------------------------------------------------- package Curses::UI::Popupmenu; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Widget; use Curses::UI::Listbox; # for maxlabelwidth() use vars qw( $VERSION @ISA ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Widget ); my %routines = ( 'loose-focus' => \&loose_focus, 'open-popup' => \&open_popup, 'select-next' => \&select_next, 'select-prev' => \&select_prev, 'mouse-button1' => \&mouse_button1, ); my %bindings = ( CUI_TAB() => 'loose-focus', KEY_BTAB() => 'loose-focus', KEY_ENTER() => 'open-popup', KEY_RIGHT() => 'open-popup', "l" => 'open-popup', CUI_SPACE() => 'open-popup', KEY_DOWN() => 'select-next', "j" => 'select-next', KEY_UP() => 'select-prev', "k" => 'select-prev', ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -parent => undef, # the parent window -width => undef, # the width of the checkbox -x => 0, # the horizontal position rel. to parent -y => 0, # the vertical position rel. to parent -values => [], # values -labels => {}, # labels for the values -selected => undef, # the current selected value -wraparound => undef, # wraparound? -sbborder => 1, # square bracket border -onchange => undef, # event handler -fg => -1, -bg => -1, %userargs, -bindings => {%bindings}, -routines => {%routines}, -focus => 0, # value init -nocursor => 1, # this widget does not use a cursor ); # The windowscr height should be 1. $args{-height} = height_by_windowscrheight(1,%args); # No width given? Then make the width large # enough to contain the longest label. $args{-width} = width_by_windowscrwidth( maxlabelwidth(%args) + 1, -border => 1 ) unless defined $args{-width}; my $this = $class->SUPER::new( %args ); $this->layout; if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding('mouse-button1', BUTTON1_CLICKED()); } return $this; } sub onChange(;$) { shift()->set_event('-onchange', shift()) } sub layout() { my $this = shift; $this->SUPER::layout() or return; # Compute the location and length of the listbox. my $ll = height_by_windowscrheight(@{$this->{-values}}, -border=>1); my $lx = $this->{-x} + $this->{-parent}->{-sx}; my $ly = $this->{-y} + $this->{-parent}->{-sy} + 1; # Don't let the listbox grow out of the screen. if ($this->{-y}+$ll > $ENV{LINES}) { $ll = $ENV{LINES} - $this->{-y}; } # It's a bit small :-( Can we place it up-side-down? my $lim = int($ENV{LINES}/2); if ($ll < $lim and ($this->{-sy}+$this->{-y}) > $lim) { $ll = height_by_windowscrheight( @{$this->{-values}}, -border=>1 ); my $y = $this->{-y}; $y -= $ll - 1; if ($y<0) { $y = 1; $ll = $this->{-y}; } $ly = $y + $this->{-parent}->{-sy} - 1; } # Store the listbox layout setup for later use. $this->{-listbox}->{-x} = $lx; $this->{-listbox}->{-y} = $ly; $this->{-listbox}->{-width} = $this->width; $this->{-listbox}->{-height} = $ll; return $this; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the widget. $this->SUPER::draw(1) or return $this; # Get the selected label. my $sellabel; if (defined $this->{-selected}) { $sellabel = $this->{-values}->[$this->{-selected}]; $sellabel = $this->{-labels}->{$sellabel} if defined $this->{-labels}->{$sellabel}; } # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } $this->{-canvasscr}->attron(A_REVERSE) if $this->{-focus}; my $width = $this->canvaswidth; if (defined $sellabel) { if (length($sellabel) > $width) { $sellabel = substr($sellabel, 0, $width); $sellabel =~ s/.$/\$/; } } else # No selection yet. { $this->{-canvasscr}->attron(A_DIM); $sellabel = "-"x$width; } $this->{-canvasscr}->addstr(0,0, " "x$width); $this->{-canvasscr}->addstr(0,0, $sellabel); $this->{-canvasscr}->move(0,$this->canvaswidth-1); $this->{-canvasscr}->attroff(A_DIM); $this->{-canvasscr}->attroff(A_REVERSE); $this->{-canvasscr}->noutrefresh; doupdate() unless $no_doupdate;; return $this; } sub open_popup() { my $this = shift; my $pre_value = $this->get; my %listbox_options = %{$this->{-listbox}}; foreach my $option (qw( -values -labels -selected -wraparound )) { $listbox_options{$option} = $this->{$option} if defined $this->{$option}; } my $id = '__popupmenu_listbox_$this'; my $listbox = $this->root->add( $id, 'PopupmenuListbox', -border => 1, -vscrollbar => 1, %listbox_options ); $listbox->modalfocus; my $post_value = $listbox->get; $this->{-selected} = $listbox->{-selected}; if ((not defined $pre_value and defined $post_value) or (defined $pre_value and $pre_value ne $post_value)) { $this->run_event('-onchange'); } $this->root->delete($id); $this->root->draw; return $this; } sub get() { my $this = shift; my $value; if (defined $this->{-selected}) { $value = $this->{-values}->[$this->{-selected}]; } return $value; } sub select_next() { my $this = shift; my $pre_value = $this->get; if (defined $this->{-selected}) { $this->{-selected}++; if ( $this->{-selected} > (@{$this->{-values}}-1) ) { $this->{-selected} = @{$this->{-values}} - 1; } } else { $this->{-selected} = 0; } my $post_value = $this->get; if ((not defined $pre_value and defined $post_value) or (defined $pre_value and $pre_value ne $post_value)) { $this->run_event('-onchange'); } $this->schedule_draw(1); return $this; } sub select_prev() { my $this = shift; my $pre_value = $this->get; if (defined $this->{-selected}) { $this->{-selected}--; $this->{-selected} = 0 if $this->{-selected} <= 0; } else { $this->{-selected} = @{$this->{-values}} - 1; } my $post_value = $this->get; if ((not defined $pre_value and defined $post_value) or (defined $pre_value and $pre_value ne $post_value)) { $this->run_event('-onchange'); } $this->schedule_draw(1); return $this; } sub mouse_button1($$$;) { my $this = shift; my $event = shift; my $x = shift; my $y = shift; unless ($this->{-focus}) { $this->focus; } $this->open_popup; } 1; =pod =head1 NAME Curses::UI::Popupmenu - Create and manipulate popupbox widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Popupmenu =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $popupbox = $win->add( 'mypopupbox', 'Popupmenu', -values => [1, 2, 3], -labels => { 1 => 'One', 2 => 'Two', 3 => 'Three' }, ); $popupbox->focus(); my $value = $popupbox->get(); =head1 DESCRIPTION Curses::UI::Popupmenu is a widget that can be used to create something very similar to a basic L. The difference is that the widget will show only the currently selected value (or "-------" if no value is yet selected). The list of possible values will be shown as a separate popup window if requested. Normally the widget will look something like this: [Current value ] If the popup window is opened, it looks something like this: [Current value ] +--------------+ |Other value | |Current value | |Third value | +--------------+ =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-values> < LIST > =item * B<-labels> < HASHREF > =item * B<-selected> < INDEX > =item * B<-wraparound> < BOOLEAN > These options are exactly the same as the options for the Listbox widget. So for an explanation of these, take a look at L. =item * B<-onchange> < CODEREF > This sets the onChange event handler for the popupmenu widget. If a new item is selected, the code in CODEREF will be executed. It will get the widget reference as its argument. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the currently selected value. =item * B ( CODEREF ) This method can be used to set the B<-onchange> event handler (see above) after initialization of the popupmenu. =back =head1 DEFAULT BINDINGS There are bindings for the widget itself and bindings for the popup listbox that can be opened by this widget. =head2 The widget itself =over 4 =item * > Call the 'loose-focus' routine. This will have the widget loose its focus. =item * >, , >, > Call the 'open-popup' routine. This will show the popup listbox and bring the focus to this listbox. See B below for a description of the bindings for this listbox. =item * >, > Call the 'select-next' routine. This will select the item in the list that is after the currently selected item (unless the last item is already selected). If no item is selected, the first item in the list will get selected. =item * >, > Call the 'select-prev' routine. This will select the item in the list that is before the currently selected item (unless the first item is already selected). If no item is selected, the first item in the list will get selected. =back =head2 The popup listbox The bindings for the popup listbox are the same as the bindings for the Listbox widget. So take a look at L for a description of these. The difference is that the 'loose-focus' and 'option-select' routine will have the popup listbox to close. If the routine 'option-select' is called, the active item will get selected. =head1 SEE ALSO L, L L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Progressbar.pm0000644000175000001440000001600011627564365017452 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Progressbar # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::Progressbar; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Widget; use vars qw( $VERSION @ISA ); @ISA = qw( Curses::UI::Widget Curses::UI::Common ); $VERSION = '1.10'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -min => 0, # minimal value -max => 100, # maximum value -pos => 0, # the current position -nopercentage => 0, # show the percentage or not? -nocenterline => 0, # show the center line or not? -showvalue => 0, # show value instead of percentage -border => 1, -fg => -1, -bg => -1, %userargs, -focusable => 0, -nocursor => 1, ); # Check that the lowest value comes first. if ($args{-min} > $args{-max}) { my $tmp = $args{-min}; $args{-min} = $args{-max}; $args{-max} = $tmp; } my $height = height_by_windowscrheight(1, %args); $args{-height} = $height; my $this = $class->SUPER::new( %args ); return $this; } sub get() { my $this = shift; return $this->{-pos}; } sub pos(;$) { my $this = shift; my $pos = shift || 0; $this->{-pos} = $pos; $this->intellidraw; return $this; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Draw the widget $this->SUPER::draw(1) or return $this; # Check bounds for the position. $this->{-pos} = $this->{-max} if $this->{-pos} > $this->{-max}; $this->{-pos} = $this->{-min} if $this->{-pos} < $this->{-min}; if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } # Compute percentage my $perc = ($this->{-pos}-$this->{-min}) /($this->{-max}-$this->{-min})*100; # Compute the number of blocks to draw. Only draw # no blocks or all blocks if resp. the min. or the # max. value is set. my $blocks = int($perc * $this->canvaswidth / 100); if ($blocks == 0 and $this->{-pos} != $this->{-min}) { $blocks++ } if ($blocks == $this->canvaswidth and $this->{-pos} != $this->{-max}) { $blocks-- } # Draw center line $this->{-canvasscr}->addstr(0, 0, "-"x$this->canvaswidth) unless $this->{-nocenterline}; # Draw blocks. $this->{-canvasscr}->attron(A_REVERSE); $this->{-canvasscr}->addstr(0, 0, " "x$blocks); $this->{-canvasscr}->attroff(A_REVERSE); # Draw percentage if (not $this->{-nopercentage} or $this->{-showvalue}) { my $str; if ($this->{-showvalue}) { $str = " $this->{-pos} "; } else { $str = " " . int($perc) . "% "; } my $len = length($str); my $xpos = int(($this->canvaswidth - $len)/2); my $revlen = $blocks - $xpos; $revlen = 0 if $revlen < 0; $revlen = $len if $revlen > $len; my $rev = substr($str, 0, $revlen); my $norev = substr($str, $revlen, $len-$revlen); $this->{-canvasscr}->attron(A_REVERSE); $this->{-canvasscr}->addstr(0, $xpos, $rev); $this->{-canvasscr}->attroff(A_REVERSE); $this->{-canvasscr}->addstr(0, $xpos+$revlen, $norev); } $this->{-canvasscr}->move(0,$this->canvaswidth-1); $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } 1; =pod =head1 NAME Curses::UI::Progressbar - Create and manipulate progressbar widgets =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Progressbar =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $progressbar = $win->add( 'myprogressbar', 'Progressbar', -max => 250, -pos => 42, ); $progressbar->draw; =head1 DESCRIPTION Curses::UI::Progressbar is a widget that can be used to provide some sort of progress information to the user of your program. The progressbar looks like this: +------------------------------------------+ |||||||||---------- 14% ------------------ | +------------------------------------------+ See exampes/demo-Curses::UI::Progressbar in the distribution for a short demo. =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-min> < VALUE > This opion sets the minimum value for the progress bar. Default is 0. =item * B<-max> < VALUE > This opion sets the maximum value for the progress bar. =item * B<-pos> < VALUE > This option sets the startposition for the progress bar. =item * B<-nopercentage> < BOOLEAN > This option controls if a percentage indicator should be drawn in the widget. The default for the BOOLEAN value is false, so a percentage incdicator will be drawn. =item * B<-showvalue> < BOOLEAN > If this option is set to a true value, the current position value will be drawn in the widget. =item * B<-nocenterline> < BOOLEAN > This option controls if a horizontal line should be drawn in the widget. The default for the BOOLEAN value is false, so a horizontal line will be drawn. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( ) These are standard methods. See L for an explanation of these. =item * B ( ) This method will return the current B<-pos> value of the widget. =item * B ( VALUE ) This method will set the B<-pos> value of the widget to SCALAR. =back =head1 DEFAULT BINDINGS Since a Progressbar is a non-interacting widget, it does not have any bindings. =head1 SEE ALSO L, L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Notebook.pm0000644000175000001440000006631211627564365016754 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Notebook # # Written by George A. Theall, theall@tifaware.com # # Copyright (c) 2004, George A. Theall. All rights reserved. # # This module is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # $Id: Notebook.pm,v 1.2 2004/10/22 21:07:27 mthies2s Exp $ # ---------------------------------------------------------------------- package Curses::UI::Notebook; use 5; use strict; use warnings; use Curses; use Curses::UI::Common; use Curses::UI::Widget; use vars qw( $VERSION @ISA ); $VERSION = '1.0001'; @ISA = qw( Curses::UI::Container ); my %routines = ( 'goto_first_page' => sub { my $this = shift; $this->activate_page($this->first_page); }, 'goto_last_page' => sub { my $this = shift; $this->activate_page($this->last_page); }, 'goto_next_page' => sub { my $this = shift; $this->activate_page($this->next_page); }, 'goto_prev_page' => sub { my $this = shift; $this->activate_page($this->prev_page); }, ); my %bindings = ( KEY_HOME() => 'goto_first_page', "\cA" => 'goto_first_page', KEY_END() => 'goto_last_page', "\cE" => 'goto_last_page', KEY_NPAGE() => 'goto_next_page', "\cN" => 'goto_next_page', KEY_PPAGE() => 'goto_prev_page', "\cP" => 'goto_prev_page', ); sub debug_msg(;$) { return unless ($Curses::UI::debug); my $caller = (caller(1))[3]; my $msg = shift || ''; my $indent = ($msg =~ /^(\s+)/ ? $1 : ''); $msg =~ s/\n/\nDEBUG: $indent/mg; warn 'DEBUG: ' . ($msg ? "$msg in $caller" : "$caller() called by " . ((caller(2))[3] || 'main') ) . "().\n"; } sub new($;) { debug_msg; my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); # nb: support only arguments listed in @valid_args; my @valid_args = ( 'x', 'y', 'width', 'height', 'pad', 'padleft', 'padright', 'padtop', 'padbottom', 'ipad', 'ipadleft', 'ipadright', 'ipadtop', 'ipadbottom', 'wraparound', 'border', 'sbborder', 'bg', 'fg', 'intellidraw', 'onchange', 'onblur', 'routines', 'bindings', 'parent', ); foreach my $arg (keys %userargs) { unless (grep($arg eq "-$_", @valid_args)) { debug_msg " deleting invalid arg '$arg'"; delete $userargs{$arg}; } } my %args = ( -x => 0, # horizontal start position -y => 0, # vertical start position -width => undef, # width -height => undef, # height (nb: including tabs) -ipadleft => 1, # left padding -ipadright => 1, # right padding -wraparound => 1, # enable wraparound when changing pages? -border => 1, # border around tabs / active window -bg => -1, # default background color -fg => -1, # default foreground color -intellidraw => 1, -routines => {%routines}, -bindings => {%bindings}, %userargs, ); foreach (sort keys %args) { debug_msg " \$args{$_} = " . (defined $args{$_} ? $args{$_} : 'n/a'); } # nb: some type of border is currently needed for tab labels. return unless ($args{-border} or $args{-sbborder}); # Create the widget. debug_msg ' creating Notebook object'; my $this = $class->SUPER::new(%args); if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding(\&mouse_button1, BUTTON1_CLICKED()); } @{$this->{-pages}} = (); # names of pages stored as an array. return $this; } sub layout($) { debug_msg; my $this = shift; # Don't wast time if we know the screen is too small. return if ($Curses::UI::screen_too_small); # Origin defaults to (0,0) relative to parent. # # nb: if origin is negative, treat it as an end-point and # as relative to parent's end-point. $this->{-y} = 0 unless (defined $this->{-y}); $this->{-x} = 0 unless (defined $this->{-x}); # Expand -pad/-ipad args. $this->process_padding; # Make sure there's enough space for the widget. # # - get parent's data. $this->{-parentdata} = $this->{-parent}->windowparameters; my $ph = $this->{-parentdata}->{-h}; my $pw = $this->{-parentdata}->{-w}; # - calculate space available to the widget. my $avail_h = $ph - ($this->{-y} < 0 ? abs($this->{-y}+1) : $this->{-y}); my $avail_w = $pw - ($this->{-x} < 0 ? abs($this->{-x}+1) : $this->{-x}); debug_msg " available height / width = $avail_h / $avail_w"; # - size of widget defaults to available space. my $h = (defined $this->{-height} ? $this->{-height} : $avail_h); my $w = (defined $this->{-width} ? $this->{-width} : $avail_w); debug_msg " size of widget = $h / $w"; # - calculate required size given borders, padding, etc. my $req_h = ($this->{-border} ? 3 : 0) + ($this->{-sbborder} ? 3 : 0) + $this->{-padtop} + $this->{-padbottom}; my $req_w = ($this->{-border} ? 2 : 0) + ($this->{-sbborder} ? 2 : 0) + $this->{-padleft} + $this->{-padright}; debug_msg " required size of widget = $req_h / $req_w"; # - make sure widget fits given what's required and available. if ( $h < $req_h or $h > $avail_h or $w < $req_w or $w > $avail_w ) { debug_msg " screen is too small!"; $Curses::UI::screen_too_small++; return $this; } # Update some widget parameters. # # - height and width. $this->{-h} = $h; $this->{-w} = $w; # - starting point. # nb: keep in mind if origin is negative, (x,y) is an end-point # relative to parent's end-point. $this->{-realy} = $this->{-y} + ($this->{-y} >= 0 ? 0 : $ph - $h + 1); $this->{-realx} = $this->{-x} + ($this->{-x} >= 0 ? 0 : $pw - $w + 1); # Create widget border, if desired. if ( $this->{-border} or $this->{-sbborder} ) { $this->{-bh} = $h - $this->{-padtop} - $this->{-padbottom}; $this->{-bw} = $w - $this->{-padleft} - $this->{-padright}; $this->{-by} = $this->{-realy} + $this->{-padtop}; $this->{-bx} = $this->{-realx} + $this->{-padleft}; my @args = ( $this->{-bh}, $this->{-bw}, $this->{-by}, $this->{-bx}, ); debug_msg " creating borderscr with args " . join(",", @args); unless ( $this->{-borderscr} = $this->{-parent}->{-canvasscr}->derwin(@args) ) { debug_msg " screen is too small for border widget!"; $Curses::UI::screen_too_small++; return $this; } } # Create widget window itself. $this->{-sh} = $this->{-bh} - $this->{-ipadtop} - $this->{-ipadbottom} - ($this->{-border} ? 4 : 0) - ($this->{-sbborder} ? 4 : 0); $this->{-sw} = $this->{-bw} - $this->{-ipadleft} - $this->{-ipadright} - ($this->{-border} ? 2 : 0) - ($this->{-sbborder} ? 2 : 0); $this->{-sy} = $this->{-by} + $this->{-ipadtop} + ($this->{-border} ? 3 : 0) + ($this->{-sbborder} ? 3 : 0); $this->{-sx} = $this->{-bx} + $this->{-ipadleft} + ($this->{-border} ? 1 : 0) + ($this->{-sbborder} ? 1 : 0); my @args = ( $this->{-sh}, $this->{-sw}, $this->{-sy}, $this->{-sx}, ); debug_msg " creating canvasscr with args " . join(",", @args); $this->{-canvasscr} = $this->{-parent}->{-canvasscr}->derwin(@args); unless (defined $this->{-canvasscr}) { debug_msg " screen is too small for window widget!"; $Curses::UI::screen_too_small++; return $this; } unless (defined $this->{-borderscr}) { $this->{-bh} = $this->{-sh}; $this->{-bw} = $this->{-sw}; $this->{-by} = $this->{-sy}; $this->{-bx} = $this->{-sx}; } return $this; } sub draw($;$) { debug_msg; my $this = shift; my $no_doupdate = shift || 0; debug_msg " \$no_doupdate = $no_doupdate"; # Return immediately if this object is hidden or if # the screen is currently too small. return if $this->hidden; return if $Curses::UI::screen_too_small; # Identify various pages of interest. my $first_page = $this->first_page; my $next_page = $this->next_page; my $last_page = $this->last_page; my $active_page = $this->active_page; # Identify page window. my $page_win = $this->{-borderscr}; # Hide cursor. eval { curs_set(0) }; # not available on every system. # Enable colors if desired. if ($Curses::UI::color_support) { debug_msg " enabling color support"; my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg} ); $page_win->attron(COLOR_PAIR($pair)); } my $ch_hbar = $this->{-border} ? ACS_HLINE : '-'; my $ch_vbar = $this->{-border} ? ACS_VLINE : '|'; my $ch_tl = $this->{-border} ? ACS_ULCORNER : '+'; my $ch_tr = $this->{-border} ? ACS_URCORNER : '+'; my $ch_bl = $this->{-border} ? ACS_LLCORNER : '+'; my $ch_br = $this->{-border} ? ACS_LRCORNER : '+'; my $ch_ttee = $this->{-border} ? ACS_TTEE : '+'; my $ch_btee = $this->{-border} ? ACS_BTEE : '+'; my $ch_ltee = $this->{-border} ? ACS_LTEE : '+'; my $ch_rtee = $this->{-border} ? ACS_RTEE : '+'; # Draw tabs along with a border if desired. my($x, $y) = (0, 0); $y = 1 if ($this->{-border} or $this->{-sbborder}); foreach my $page (@{$this->{-pages}}) { debug_msg " drawing tab for page '$page'"; if ($this->{-border} or $this->{-sbborder}) { debug_msg " adding left border at x=$x"; $page_win->addch(0, $x, ($page eq $first_page ? $ch_tl : $ch_ttee)); $page_win->addch(1, $x, $ch_vbar); $page_win->addch(2, $x, ($page eq $first_page ? ($page eq $active_page ? $ch_vbar : $ch_ltee ) : ($page eq $active_page ? $ch_br : ($page eq $next_page ? $ch_bl : $ch_btee ) ) ) ); ++$x; } debug_msg " adding $this->{-ipadleft} space" . ($this->{-ipadright} == 1 ? "" : "s") . " of padding at x=$x"; if ($this->{-border} or $this->{-sbborder}) { for (my $i = 0; $i < $this->{-ipadleft}; $i++) { $page_win->addch(0, $x, $ch_hbar); # $page_win->addch(2, $x, ($page eq $active_page ? ' ' : $ch_hbar)); ++$x; } } else { $x += $this->{-ipadleft}; } debug_msg " writing page name at x=$x"; $page_win->attron(A_REVERSE) if ($page eq $active_page); $page_win->addstr($y, $x, $page); $page_win->attroff(A_REVERSE) if ($page eq $active_page); if ($this->{-border} or $this->{-sbborder}) { for (my $i = 0; $i < length($page); $i++) { $page_win->addch(0, $x, $ch_hbar); # $page_win->addch(2, $x, ($page eq $active_page ? ' ' : $ch_hbar)); ++$x; } } else { $x += length($page); } debug_msg " adding $this->{-ipadright} space" . ($this->{-ipadright} == 1 ? "" : "s") . " of padding at x=$x"; if ($this->{-border} or $this->{-sbborder}) { for (my $i = 0; $i < $this->{-ipadright}; $i++) { $page_win->addch(0, $x, $ch_hbar); # $page_win->addch(2, $x, ($page eq $active_page ? ' ' : $ch_hbar)); ++$x; } } else { $x += $this->{-ipadright}; } if (($this->{-border} or $this->{-sbborder}) and $page eq $last_page) { debug_msg " adding right border at x=$x"; $page_win->addch(0, $x, $ch_tr); $page_win->addch(1, $x, $ch_vbar); $page_win->addch(2, $x, ($page eq $active_page ? $ch_bl : $ch_btee)); ++$x; } } if ($this->{-border} or $this->{-sbborder}) { do { $page_win->addch(2, $x, $ch_hbar); } while (++$x < $this->{-bw}-1); $page_win->addch(2, $x, $ch_tr); for ($y = 3; $y < $this->{-bh}-1; $y++) { $page_win->addch($y, $this->{-x}, $ch_vbar); $page_win->addch($y, $x, $ch_vbar); } $page_win->addch($y, $this->{-x}, $ch_bl); for ($x = $this->{-x}+1; $x < $this->{-bw}-1; $x++) { $page_win->addch($y, $x, $ch_hbar); } $page_win->addch($y, $x, $ch_br); } $page_win->noutrefresh; # Draw active window. $this->getobj($active_page)->draw($no_doupdate); doupdate unless ($no_doupdate); return $this; } # NB: we can't simply inherit intellidraw from Curses::UI::Widget # since notebooks themselves contain window objects. sub intellidraw(;$) { debug_msg; my $this = shift; if ($this->{-intellidraw} and !$this->hidden) { # Check if parent window has modal focus or is on top of focus path. my $parent = $this->parentwindow; debug_msg " parent window = " . $parent; my @path = $this->root->focus_path; debug_msg " focus_path " . join(" & ", @path); # Ignore anything above our object. while (grep($_ eq $this, @path)) { $_ = pop(@path); debug_msg " skipping $_ to find ourselves"; } # Now find next window. while (@path > 1 and !$path[-1]->isa('Curses::UI::Window')) { $_ = pop(@path); debug_msg " skipping $_ to find previous window"; } debug_msg " next window = " . (@path ? $path[-1] : 'n/a'); $this->draw if ( $parent->{-has_modal_focus} or (@path and $parent eq $path[-1]) ); } return $this; } sub add_page($$;) { debug_msg; my $this = shift; my $page = shift or return; debug_msg " adding '$page' page"; # Make sure page is not yet part of the notebook. $this->root->fatalerror("The notebook already has a page named '$page'!") if (defined $this->{-id2object}->{$page}); # Make sure the page does not cause the 'tabs' window to overflow. my $len = 0; foreach my $page (@{$this->{-pages}}, $page) { $len += length($page) + ($this->{-ipadleft} || 0) + ($this->{-ipadright} || 0) + ($this->{-border} || 0) + ($this->{-sbborder} || 0); } ++$len; # nb: needed for final border char. debug_msg " $len spaces are needed for tab labels"; if ($len > $this->{-bw}) { debug_msg " screen is too small - width is $this->{-bw}"; $Curses::UI::screen_too_small++; return; }; # Create a window for this page using same layout as widget's canvasscr. my %userargs = @_; keys_to_lowercase(\%userargs); # grab callback arguments foreach my $cbkey (qw/-on_activate -on_delete/) { $this->{callback}{$page}{$cbkey} = delete $userargs{$cbkey} if defined $userargs{$cbkey}; } $this->add( $page, 'Window', -padtop => $this->{-padtop}, -padbottom => $this->{-padbottom}, -padleft => $this->{-padleft}, -padright => $this->{-padright}, -ipadtop => $this->{-ipadtop}, -ipadbottom => $this->{-ipadbottom}, -ipadleft => $this->{-ipadleft}, -ipadright => $this->{-ipadright}, -fg => $this->{-fg}, # nb: no color support in -bg => $this->{-bg}, # Curses::UI::Window yet! %userargs, -height => $this->{-sh}, -width => $this->{-sw}, -y => 0, # nb: x,y are relative to canvasscr! -x => 0, ); push(@{$this->{-pages}}, $page); if (@{$this->{-pages}} == 1) { $this->{-active_page} = $page; } else { # Adding the window object alters the draw- and focusorder so # we need to adjust them manually. my $active_page = $this->active_page; $this->set_draworder($active_page); $this->set_focusorder($active_page); } return $this->getobj($page); } sub delete_page($$) { debug_msg; my $this = shift; my $page = shift or return; # Make sure page is part of the notebook. $this->root->fatalerror("The notebook widget does not have a page named '$page'!") unless (defined $this->{-id2object}->{$page}); debug_msg " deleting '$page' page"; if (defined $this->{callback}{$page}{-on_delete}) { debug_msg " calling delete callback for $page"; $this->{callback}{$page}{-on_delete}->($this,$page); } my $active_page = $this->active_page; @{$this->{-pages}} = grep($page ne $_, @{$this->{-pages}}); $this->activate_page($this->first_page) if ($page eq $active_page); $this->SUPER::DESTROY($page); return; } sub active_page($) { debug_msg; my $this = shift; return unless (@{$this->{-pages}}); my $page = defined $this->{-active_page} ? $this->{-active_page} : ($this->{-active_page} = ''); debug_msg " active page = '$page'"; return $page; } sub first_page($) { debug_msg; my $this = shift; return unless (@{$this->{-pages}}); my $page = ${$this->{-pages}}[0]; debug_msg " first page = '$page'"; return $page; } sub last_page($) { debug_msg; my $this = shift; return unless (@{$this->{-pages}}); my $page = ${$this->{-pages}}[$#{$this->{-pages}}]; debug_msg " last page = '$page'"; return $page; } sub prev_page($) { debug_msg; my $this = shift; return unless (@{$this->{-pages}}); my $active_page = $this->active_page; my $i = scalar(@{$this->{-pages}}); while (--$i >= 0) { last if ($active_page eq ${$this->{-pages}}[$i]); } return if ($i < 0); $i = $i > 0 ? $i-1 : $this->{-wraparound} ? $#{$this->{-pages}} : 0; my $page = ${$this->{-pages}}[$i]; debug_msg " prev page = '$page'"; return $page; } sub next_page($) { debug_msg; my $this = shift; return unless (@{$this->{-pages}}); my $active_page = $this->active_page; my $i = scalar(@{$this->{-pages}}); while (--$i >= 0) { last if ($active_page eq ${$this->{-pages}}[$i]); } return if ($i < 0); $i = $i < $#{$this->{-pages}} ? $i+1 : $this->{-wraparound} ? 0 : $#{$this->{-pages}}; my $page = ${$this->{-pages}}[$i]; debug_msg " next page = '$page'"; return $page; } sub activate_page($$) { debug_msg; my $this = shift; my $page = shift or return; # Make sure page is part of the notebook. $this->root->fatalerror("The notebook widget does not have a page named '$page'!") unless (defined $this->{-id2object}->{$page}); my $active_page = $this->active_page; debug_msg " old active page = '$active_page'"; if (defined $this->{callback}{$page}{-on_activate}) { debug_msg " calling activate callback for $page"; $this->{callback}{$page}{-on_activate}->($this,$page); } if ($active_page ne $page) { $active_page = $this->{-active_page} = $page; debug_msg " new active page = '$active_page'"; $this->set_draworder($active_page); $this->set_focusorder($active_page); # Redraw the notebook widget only if in curses mode. $this->intellidraw unless isendwin; } return $active_page; } sub mouse_button1($$$$) { debug_msg; my $this = shift; my $event = shift; my $x = shift; my $y = shift; my $ev_x = $event->{-x}; my $ev_y = $event->{-y}; debug_msg " mouse click at ($ev_x,$ev_y)"; # Focus window if it isn't already in focus. $this->focus if (not $this->{-focus} and $this->focusable); # If click was in the 'tabs' window. if ($ev_y <= ($this->{-border} + $this->{-sbborder} ? 3 : 1)) { # Figure out which page was clicked. my $len = 0; foreach my $page (@{$this->{-pages}}) { $len += length($page) + ($this->{-ipadleft} || 0) + ($this->{-ipadright} || 0) + ($this->{-border} || 0) + ($this->{-sbborder} || 0); if ($ev_x < $len) { debug_msg " user clicked on tab for '$page'"; return $this->activate_page($page); } } debug_msg " user didn't click on a tab label; ignored"; } else { my $active_page = $this->active_page; debug_msg " user clicked on window of active page"; $this->getobj($active_page)->mouse_button1($event, $x, $y); } } 1; =pod =head1 NAME Curses::UI::Notebook - Create and manipulate notebook widgets. =head1 CLASS HIERARCHY Curses::UI::Widget | +----Curses::UI::Container | +----Curses::UI::Notebook =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add(undef, 'Window'); my $notebook = $win->add(undef, 'Notebook'); my $page1 = $notebook->add_page('page 1'); $page1->add( undef, 'Label', -x => 15, -y => 6, -text => "Page #1.", ); my $page2 = $notebook->add_page('page 2'); $page2->add( undef, 'Label', -x => 15, -y => 6, -text => "Page #2.", ); my $page3 = $notebook->add_page('page 3', -on_activate => \&sub ); $page3->add( undef, 'Label', -x => 15, -y => 6, -text => "Page #3.", ); $notebook->focus; $cui->mainloop; =head1 DESCRIPTION This package implements a I similar to that found in Motif. A I holds several windows, or I, only one of which is visible at any given time; tabs at the top of the widget list the pages that are available. In this way, a great deal of information can be fit into a relatively small screen area. [Windows users might recognize this as a I.] =head1 STANDARD OPTIONS B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-border>, B<-sbborder>, B<-bg>, B<-fg>, B<-intellidraw>, B<-onchange>, B<-onblur>. See L for a discussion of each of these options. Note that B<-border> is enabled and both B<-ipadleft> and B<-ipadright> are set to C<1> by default when creating notebook objects. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-bindings> < HASHREF > The keys in this hash reference are keystrokes and the values are routines to which they should be bound. In the event a key is empty, the corresponding routine will become the default routine that B applies to unmatched keystrokes it receives. By default, the following mappings are used: KEY ROUTINE ------------------ ---------- KEY_HOME, Ctrl-A first_page KEY_END, Ctrl-E last_page KEY_NPAGE, Ctrl-N next_page KEY_PPAGE, Ctrl-P prev_page =item * B<-routines> < HASHREF > The keys in this hash reference are routines and the values are either scalar values or code references. B maps keystrokes to routines and then to either a scalar value, which it returns, or a code reference, which it executes. By default, the following mappings are used: ROUTINE ACTION ---------- ------------------------- first_page make first page active last_page make last page active next_page make next page active prev_page make previous page active =item * B<-wraparound> < BOOLEAN > If BOOLEAN has a true value, wraparound is enabled. This means that advancing to the next page will cycle from the last back to the first page and similarly, advancing to the previous page will cycle from the first back to the last page. By default, it is true. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) Constructs a new notebook object using options in the hash OPTIONS. =item * B ( ) Lays out the notebook object, makes sure it fits on the available screen, and creates the curses windows for the border / tab labels as well as the effective drawing area. =item * B ( BOOLEAN ) Draws the notebook object along with the active page's window. If BOOLEAN is true, the screen is not updated after drawing. By default, BOOLEAN is true so the screen is updated. =item * B ( ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) See L for explanations of these methods. =item * B ( PAGE [ , -on_activate => sub_ref ] [, -on_delete => ] ) Adds the specified page to the notebook object and creates an associated window object. Returns the window object or undef on failure. Note: the add fails if the page would otherwise cause the tab window to overflow or is already part of the notebook object. The C<-on_activate> parameter specifies an optional call-back that will be invoked when the page is activated. This call-back will be called with the notebook widget and page name as parameter. Likewise for C<-on_delete> call-back. This one is invoked when the page is deleted. =item * B ( PAGE ) Deletes the specified page from the notebook object and destroys its associated window object. If the page was active, the first page is made active. =item * B ( ) Returns the currently active page in the notebook object. =item * B ( ) Returns the first page in the notebook object. =item * B ( ) Returns the last page in the notebook object. =item * B ( ) Returns the previous page in the notebook object. =item * B ( ) Returns the next page in the notebook object. =item * B ( PAGE ) Makes the specified page in the notebook object active and returns it, redrawing the notebook object in the process. =item * B ( ) Processes mouse button #1 clicks. If the user left-clicks on one of the tabs, B is called with the corresponding page to make it active; otherwise, the click is passed along to the active window. =back =head1 SEE ALSO L, L, L =head1 AUTHOR George A. Theall, Etheall@tifaware.comE =head1 COPYRIGHT AND LICENSE Copyright (c) 2004, George A. Theall. All rights reserved. This script is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Curses-UI-0.9609/lib/Curses/UI/Common.pm0000644000175000001440000004166411627564365016427 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Common # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # (c) 2003-2005 by Marcus Thiesen et al. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::Common; use strict; use Term::ReadKey; use Curses; require Exporter; use vars qw( @ISA @EXPORT_OK @EXPORT $VERSION ); $VERSION = '1.10'; @ISA = qw( Exporter ); @EXPORT = qw( keys_to_lowercase text_wrap text_draw text_length text_chop scrlength split_to_lines text_dimension CUI_ESCAPE CUI_SPACE CUI_TAB WORDWRAP NO_WORDWRAP ); # ---------------------------------------------------------------------- # Misc. routines # ---------------------------------------------------------------------- sub parent() { my $this = shift; $this->{-parent}; } sub root() { my $this = shift; my $root = $this; while (defined $root->{-parent}) { $root = $root->{-parent}; } return $root; } sub accessor($;$) { my $this = shift; my $key = shift; my $value = shift; $this->{$key} = $value if defined $value; return $this->{$key}; } sub keys_to_lowercase($;) { my $hash = shift; my $copy = {%$hash}; while (my ($k,$v) = each %$copy) { $hash->{lc $k} = $v; } return $hash; } # ---------------------------------------------------------------------- # Text processing # ---------------------------------------------------------------------- sub split_to_lines($;) { # Make $this->split_to_lines() possible. shift if ref $_[0]; my $text = shift; # Break up the text in lines. IHATEBUGS is # because a split with /\n/ on "\n\n\n" would # return zero result :-( my @lines = split /\n/, $text . "IHATEBUGS"; $lines[-1] =~ s/IHATEBUGS$//g; return \@lines; } sub scrlength($;) { # Make $this->scrlength() possible. shift if ref $_[0]; my $line = shift; return 0 unless defined $line; my $scrlength = 0; for (my $i=0; $i < length($line); $i++) { my $chr = substr($line, $i, 1); $scrlength++; if ($chr eq "\t") { while ($scrlength%8) { $scrlength++; } } } return $scrlength; } # Contstants for text_wrap() sub NO_WORDWRAP() { 1 } sub WORDWRAP() { 0 } sub text_wrap($$;) { # Make $this->text_wrap() possible. shift if ref $_[0]; my ($line, $maxlen, $wordwrap) = @_; $wordwrap = WORDWRAP unless defined $wordwrap; $maxlen = int $maxlen; return [""] if $line eq ''; my @wrapped = (); my $len = 0; my $wrap = ''; # Special wrapping is needed if the line contains tab # characters. These should be expanded to the TAB-stops. if ($line =~ /\t/) { CHAR: for (my $i = 0; $i <= length($line); $i++) { my $nextchar = substr($line, $i, 1); # Find the length of the string in case the # next character is added. my $newlen = $len + 1; if ($nextchar eq "\t") { while($newlen%8) { $newlen++ } } # Would that go beyond the end of the available width? if ($newlen > $maxlen) { if ($wordwrap == WORDWRAP and $wrap =~ /^(.*)([\s])(\S+)$/) { push @wrapped, $1 . $2; $wrap = $3; $len = scrlength($wrap) + 1; } else { $len = 1; push @wrapped, $wrap; $wrap = ''; } } else { $len = $newlen; } $wrap .= $nextchar; } push @wrapped, $wrap if defined $wrap; # No tab characters in the line? Then life gets a bit easier. We can # process large chunks at once. } else { my $idx = 0; # Line shorter than allowed? Then return immediately. return [$line] if length($line) < $maxlen; return ["internal wrap error: wraplength undefined"] unless defined $maxlen; CHUNK: while ($idx < length($line)) { my $next = substr($line, $idx, $maxlen); if (length($next) < $maxlen) { push @wrapped, $next; last CHUNK; } elsif ($wordwrap == WORDWRAP) { my $space_idx = rindex($next, " "); if ($space_idx == -1 or $space_idx == 0) { push @wrapped, $next; $idx += $maxlen; } else { push @wrapped, substr($next, 0, $space_idx + 1); $idx += $space_idx + 1; } } else { push @wrapped, $next; $idx += $maxlen; } } } return \@wrapped; } sub text_tokenize { my ($text) = @_; my @tokens = (); while ($text ne '') { if ($text =~ m/^<\/?[a-zA-Z0-9_]+>/s) { push(@tokens, $&); $text = $'; } elsif ($text =~ m/^.+?(?=<\/?[a-zA-Z0-9_]+>)/s) { push(@tokens, $&); $text = $'; } else { push(@tokens, $text); last; } } return @tokens; } sub text_draw($$;) { my $this = shift; my ($y, $x, $text) = @_; if ($this->{-htmltext}) { my @tokens = &text_tokenize($text); foreach my $token (@tokens) { if ($token =~ m/^<(standout|reverse|bold|underline|blink|dim)>$/s) { my $type = $1; if ($type eq 'standout') { $this->{-canvasscr}->attron(A_STANDOUT); } elsif ($type eq 'reverse') { $this->{-canvasscr}->attron(A_REVERSE); } elsif ($type eq 'bold') { $this->{-canvasscr}->attron(A_BOLD); } elsif ($type eq 'underline') { $this->{-canvasscr}->attron(A_UNDERLINE); } elsif ($type eq 'blink') { $this->{-canvasscr}->attron(A_BLINK); } elsif ($type eq 'dim') { $this->{-canvasscr}->attron(A_DIM); } } elsif ($token =~ m/^<\/(standout|reverse|bold|underline|blink|dim)>$/s) { my $type = $1; if ($type eq 'standout') { $this->{-canvasscr}->attroff(A_STANDOUT); } elsif ($type eq 'reverse') { $this->{-canvasscr}->attroff(A_REVERSE); } elsif ($type eq 'bold') { $this->{-canvasscr}->attroff(A_BOLD); } elsif ($type eq 'underline') { $this->{-canvasscr}->attroff(A_UNDERLINE); } elsif ($type eq 'blink') { $this->{-canvasscr}->attroff(A_BLINK); } elsif ($type eq 'dim') { $this->{-canvasscr}->attroff(A_DIM); } # Tags: (see, man 5 terminfo) # | <4_ACS_VLINE> -- Vertical line (4 items). # -- <5_ACS_HLINE> -- Horizontal line (5 items). # ` <12_ACS_TTEE> -- Tee pointing down (12 items). # ~ -- Tee pointing up (1 item). # + -- Large plus or crossover (1 item). # ------------------------------------------------------------------ } elsif ($token =~ m/^<(\d*)_?(ACS_HLINE|ACS_VLINE|ACS_TTEE|ACS_BTEE|ACS_PLUS)>$/s) { no strict 'refs'; my $scrlen = ($1 || 1); my $type = &{ $2 }; $this->{-canvasscr}->hline( $y, $x, $type, $scrlen ); $x += $scrlen; } else { $this->{-canvasscr}->addstr($y, $x, $token); $x += length($token); } } } else { $this->{-canvasscr}->addstr($y, $x, $text); } } sub text_length { my $this = shift; my ($text) = @_; my $length = 0; if ($this->{-htmltext}) { my @tokens = &text_tokenize($text); foreach my $token (@tokens) { if ($token !~ m/^<\/?(reverse|bold|underline|blink|dim)>$/s) { $length += length($token); } } } else { $length = length($text); } return $length; } sub text_chop { my $this = shift; my ($text, $max_length) = @_; if ($this->{-htmltext}) { my @open = (); my @tokens = &text_tokenize($text); my $length = 0; $text = ''; foreach my $token (@tokens) { if ($token =~ m/^<(\/?)(reverse|bold|underline|blink|dim)>/s) { my ($type, $name) = ($1, $2); if (defined($type) and $type eq '/') { pop(@open); } else { push(@open, $name); } $text .= $token; } else { $text .= $token; $length += length($token); if ($length > $max_length) { $text = substr($text, 0, $max_length); $text =~ s/.$/\$/; while (defined($token = pop(@open))) { $text .= ""; } last; } } } } else { if (length($text) > $max_length) { $text = substr($text, 0, $max_length); } } return $text; } sub text_dimension ($;) { # Make $this->text_wrap() possible. shift if ref $_[0]; my $text = shift; my $lines = split_to_lines($text); my $height = scalar @$lines; my $width = 0; foreach (@$lines) { my $l = length($_); $width = $l if $l > $width; } return ($width, $height); } # ---------------------------------------------------------------------- # Keyboard input # ---------------------------------------------------------------------- # Constants: # Keys that are not defined in curses.h, but which might come in handy. sub CUI_ESCAPE() { "\x1b" } sub CUI_TAB() { "\t" } sub CUI_SPACE() { " " } # Make ascii representation of a key. sub key_to_ascii($;) { my $this = shift; my $key = shift; if ($key eq CUI_ESCAPE()) { $key = ''; } # Control characters. Change them into something printable # via Curses' unctrl function. elsif ($key lt ' ' and $key ne "\n" and $key ne "\t") { $key = '<' . uc(unctrl($key)) . '>'; } # Extended keys get translated into their names via Curses' # keyname function. elsif ($key =~ /^\d{2,}$/) { $key = '<' . uc(keyname($key)) . '>'; } return $key; } # For the select() syscall in char_read(). my $rin = ''; my $fno = fileno(STDIN); $fno = 0 unless $fno >= 0; vec($rin, $fno , 1) = 1; sub char_read(;$) { my $this = shift; my $blocktime = shift; # Initialize the toplevel window for # reading a key. my $s = $this->root->{-canvasscr}; noecho(); raw(); $s->keypad(1); # Read input on STDIN. my $key = '-1'; $blocktime = undef if $blocktime < 0; # Wait infinite my $crin = $rin; $! = 0; my $found = select($crin, undef, undef, $blocktime); if ($found < 0 ) { print STDERR "DEBUG: get_key() -> select() -> $!\n" if $Curses::UI::debug; } elsif ($found) { $key = $s->getch(); } return $key; } sub get_key(;$) { my $this = shift; my $blocktime = shift || 0; my $key = $this->char_read($blocktime); # ------------------------------------ # # Hacks for broken termcaps / curses # # ------------------------------------ # $key = KEY_BACKSPACE if ( ord($key) == 127 or $key eq "\cH" ); $key = KEY_DC if ( $key eq "\c?" or $key eq "\cD" ); $key = KEY_ENTER if ( $key eq "\n" or $key eq "\cM" ); # Catch ESCape sequences. my $ESC = CUI_ESCAPE(); if ($key eq $ESC) { $key .= $this->char_read(0); # Only ESC pressed? $key = $ESC if $key eq "${ESC}-1" or $key eq "${ESC}${ESC}"; return $key if $key eq $ESC; # Not only a single ESC? # Then get extra keypresses. $key .= $this->char_read(0); while ($key =~ /\[\d+$/) { $key .= $this->char_read(0); } # Function keys on my Sun Solaris box. # I have no idea of the portability of # this stuff, but it works for me... if ($key =~ /\[(\d+)\~/) { my $digit = $1; if ($digit >= 11 and $digit <= 15) { $key = KEY_F($digit-10); } elsif ($digit >= 17 and $digit <= 21) { $key = KEY_F($digit-11); } } $key = KEY_HOME if ( $key eq $ESC . "OH" or $key eq $ESC . "[7~" or $key eq $ESC . "[1~" ); $key = KEY_BTAB if ( $key eq $ESC . "OI" or # My xterm under solaris $key eq $ESC . "[Z" # My xterm under Redhat Linux ); $key = KEY_DL if ( $key eq $ESC . "[2K" ); $key = KEY_END if ( $key eq $ESC . "OF" or $key eq $ESC . "[4~" ); $key = KEY_PPAGE if ( $key eq $ESC . "[5~" ); $key = KEY_NPAGE if ( $key eq $ESC . "[6~" ); } # ----------# # Debugging # # ----------# if ($Curses::UI::debug and $key ne "-1") { my $k = ''; my @k = split //, $key; foreach (@k) { $k .= $this->key_to_ascii($_) } print STDERR "DEBUG: get_key() -> [$k]\n" } return $key; } 1; =pod =head1 NAME Curses::UI::Common - Common methods for Curses::UI =head1 CLASS HIERARCHY Curses::UI::Common - base class =head1 SYNOPSIS package MyPackage; use Curses::UI::Common; use vars qw(@ISA); @ISA = qw(Curses::UI::Common); =head1 DESCRIPTION Curses::UI::Common is a collection of methods that is shared between Curses::UI classes. =head1 METHODS =head2 Various methods =over 4 =item * B ( ) Returns the data member $this->{B<-parent>}. =item * B ( ) Returns the topmost B<-parent> (the Curses::UI instance). =item * B ( ) This method will walk through all the data members of the class intance. Each data member that is a Curses::Window descendant will be removed. =item * B ( NAME, [VALUE] ) If VALUE is set, the value for the data member $this->{NAME} will be changed. The method will return the current value for data member $this->{NAME}. =item * B ( HASHREF ) All keys in the hash referred to by HASHREF will be converted to lower case. =back =head2 Text processing =over 4 =item B ( TEXT ) This method will split TEXT into a list of separate lines. It returns a reference to this list. =item B ( LINE ) Returns the screenlength of the string LINE. The difference with the perl function length() is that this method will expand TAB characters. It is exported by this class and it may be called as a stand-alone routine. =item B ( TEXT ) This method will return an array containing the width (the length of the longest line) and the height (the number of lines) of the TEXT. =item B ( LINE, LENGTH, WORDWRAP ) =item B ( ) =item B ( ) This method will wrap a line of text (LINE) to a given length (LENGTH). If the WORDWRAP argument is true, wordwrap will be enabled (this is the default for WORDWRAP). It will return a reference to a list of wrapped lines. It is exported by this class and it may be called as a stand-alone routine. The B and B routines will return the correct value vor the WORDWRAP argument. These routines are exported by this class. Example: $this->text_wrap($line, 50, NO_WORDWRAP); =back =head2 Reading key input =over 4 =item B ( ) =item B ( ) =item B ( ) These are a couple of routines that are not defined by the L module, but which might be useful anyway. These routines are exported by this class. =item B ( BLOCKTIME, CURSOR ) This method will try to read a key from the keyboard. It will return the key pressed or -1 if no key was pressed. It is exported by this class and it may be called as a stand-alone routine. The BLOCKTIME argument can be used to set the curses halfdelay (the time to wait before the routine decides that no key was pressed). BLOCKTIME is given in tenths of seconds. The default is 0 (non-blocking key read). Example: my $key = $this->get_key(5) =back =head1 SEE ALSO L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/TextEditor.pm0000644000175000001440000013024211627565733017261 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::TextEditor # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- # TODO: fix dox package Curses::UI::TextEditor; use strict; use Curses; use Curses::UI::Common; use Curses::UI::Widget; use Curses::UI::Searchable; use vars qw( $VERSION @ISA ); $VERSION = '1.5'; @ISA = qw( Curses::UI::Widget Curses::UI::Common Curses::UI::Searchable ); # Configuration: routine name to subroutine mapping. my %routines = ( 'loose-focus' => \&loose_focus, 'undo' => \&undo, 'paste' => \&paste, 'delete-till-eol' => \&delete_till_eol, 'delete-line' => \&delete_line, 'delete-character' => \&delete_character, 'add-string' => \&add_string, 'clear-line' => \&clear_line, 'backspace' => \&backspace, 'newline' => \&newline, 'toggle-showhardreturns' => \&toggle_showhardreturns, 'toggle-showoverflow' => \&toggle_showoverflow, 'toggle-wrapping' => \&toggle_wrapping, 'cursor-right' => \&cursor_right, 'cursor-left' => \&cursor_left, 'cursor-up' => \&cursor_up, 'cursor-down' => \&cursor_down, 'cursor-pageup' => \&cursor_pageup, 'cursor-pagedown' => \&cursor_pagedown, 'cursor-scrlinestart' => \&cursor_to_scrlinestart, 'cursor-scrlineend' => \&cursor_to_scrlineend, 'cursor-home' => \&cursor_to_home, 'cursor-end' => \&cursor_to_end, 'search-forward' => \&search_forward, 'search-backward' => \&search_backward, 'mouse-button1' => \&mouse_button1, ); # Configuration: binding to routine name mapping. my %basebindings = ( CUI_TAB() => 'loose-focus', KEY_BTAB() => 'loose-focus', KEY_LEFT() => 'cursor-left', "\cB" => 'cursor-left', KEY_RIGHT() => 'cursor-right', "\cF" => 'cursor-right', KEY_DOWN() => 'cursor-down', "\cN" => 'cursor-down', KEY_UP() => 'cursor-up', "\cP" => 'cursor-up', KEY_PPAGE() => 'cursor-pageup', KEY_NPAGE() => 'cursor-pagedown', KEY_HOME() => 'cursor-home', KEY_END() => 'cursor-end', "\cA" => 'cursor-scrlinestart', "\cE" => 'cursor-scrlineend', "\cW" => 'toggle-wrapping', "\cR" => 'toggle-showhardreturns', "\cT" => 'toggle-showoverflow', ); my %viewbindings = ( "/" => 'search-forward', "?" => 'search-backward', CUI_SPACE() => 'cursor-pagedown', "-" => 'cursor-pageup', "]" => 'cursor-pagedown', "[" => 'cursor-pageup', ); my %editbindings = ( '' => 'add-string', "\cZ" => 'undo', KEY_DL() => 'delete-line', "\cY" => 'delete-line', "\cX" => 'delete-line', "\cK" => 'delete-till-eol', KEY_DC() => 'delete-character', "\cV" => 'paste', "\cU" => 'clear-line', KEY_BACKSPACE() => 'backspace', KEY_ENTER() => 'newline', ); # Some viewbindings that should not be available in %bindings; $viewbindings{'h'} = 'cursor-left'; $viewbindings{'j'} = 'cursor-down'; $viewbindings{'k'} = 'cursor-up'; $viewbindings{'l'} = 'cursor-right'; sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( # Parent info -parent => undef, # the parent object # Position and size -x => 0, # horizontal position (rel. to -window) -y => 0, # vertical position (rel. to -window) -width => undef, # horizontal editsize, undef = stretch -height => undef, # vertical editsize, undef = stretch -singleline => 0, # single line mode or not? # Initial state -text => '', # data -pos => 0, # cursor position # General options -border => undef, # use border? -showlines => undef, # underline lines? -sbborder => undef, # square bracket border? -undolevels => 10, # number of undolevels. 0 = infinite -maxlength => 0, # the maximum length. 0 = infinite -showoverflow => 1, # show overflow characters. -regexp => undef, # regexp to match the text against -toupper => 0, # convert text to uppercase? -tolower => 0, # convert text to lowercase? -homeonblur => 0, # cursor to homepos on blur? -vscrollbar => 0, # show vertical scrollbar -hscrollbar => 0, # show horizontal scrollbar -readonly => 0, # only used as viewer? -reverse => 0, # show in reverse # Single line options -password => undef, # masquerade chars with given char # Multiple line options -showhardreturns => 0, # show hard returns with diamond char? -wrapping => 0, # do wrap? -maxlines => undef, # max lines. undef = infinite # Events -onchange => undef, # onChange event handler # Color -bg => -1, -fg => -1, %userargs, -routines => {%routines}, # binding routines -bindings => {}, # these are set by readonly() # Init values -nocursor => 0, -scr_lines => [], -yscrpos => 0, -xscrpos => 0, -ypos => 0, -xpos => 0, -focus => 0, ); # Let -text always be defined. $args{-text} = '' unless defined $args{-text}; # If initially wrapping is on, then we do not use # overflow chars. $args{-showoverflow} = 0 if $args{-wrapping}; # Single line mode? Compute the needed height and set it. if ($args{-singleline}) { my $height = height_by_windowscrheight(1,%args); $args{-height} = $height; } # Create the Widget. my $this = $class->SUPER::new( %args ); # Check if we should wrap or not. $this->{-wrapping} = 0 if $this->{-singleline}; $this->{-undotext} = [$this->{-text}]; $this->{-undopos} = [$this->{-pos}]; $this->{-xscrpos} = 0; # X position for cursor on screen $this->{-yscrpos} = 0; # Y position for cursor on screen $this->{-xpos} = 0; # X position for cursor in the document $this->{-ypos} = 0; # Y position for cursor in the document # Restrict the password character to a single character. $this->set_password_char($this->{-password}) if defined $this->{-password}; # Single line? Then initial text may only be singleline. if ($this->{-singleline} and defined $this->{-text} and $this->{-text} =~ /\n/) { my $lines = $this->split_to_lines($this->{-text}); $this->{-text} = $lines->[0]; } $this->readonly($this->{-readonly}); $this->layout_content; if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding('mouse-button1', BUTTON1_CLICKED()); } return $this; } sub getrealxpos() { my $this = shift; my $offset = $this->{-xscrpos}; my $length = $this->{-xpos} - $this->{-xscrpos}; return 0 if $length <= 0; my $current_line = $this->{-scr_lines}->[$this->{-ypos}]; my $before_cursor = substr( $current_line, $this->{-xscrpos}, # Screen's x position $this->{-xpos} - $this->{-xscrpos} # Space up to the cursor ); my $realxpos = scrlength($before_cursor); return $realxpos; } sub layout() { my $this = shift; $this->SUPER::layout() or return; # Scroll up if we can and the number of visible lines # is smaller than the number of available lines in the screen. my $inscreen = ($this->canvasheight - ($this->number_of_lines - $this->{-yscrpos})); while ($this->{-yscrpos} > 0 and $inscreen < $this->canvasheight) { $this->{-yscrpos}--; $inscreen = ($this->canvasheight - ($this->number_of_lines - $this->{-yscrpos})); } # Scroll left if we can and the number of visible columns # is smaller than the number of available columns in the screen. $inscreen = ($this->canvaswidth - ($this->number_of_columns - $this->{-xscrpos})); while ($this->{-xscrpos} > 0 and $inscreen < $this->canvaswidth) { $this->{-xscrpos}--; $inscreen = ($this->canvaswidth - ($this->number_of_columns - $this->{-xscrpos})); } $this->layout_content(); return $this; } sub layout_content() { my $this = shift; return $this if $Curses::UI::screen_too_small; # ---------------------------------------------------------------------- # Build an array of lines to display and determine the cursor position # ---------------------------------------------------------------------- my $lines_src = $this->split_to_lines($this->{-text}); foreach (@$lines_src) {$_ .= "\n"} $lines_src->[-1] =~ s/\n$/ /; # No lines available? Then create an array. $lines_src = [""] unless @$lines_src; # No out of bound values for -pos. $this->{-pos} = 0 unless defined $this->{-pos}; $this->{-pos} = 0 if $this->{-pos} < 0; $this->{-pos} = length($this->{-text}) if $this->{-pos} >= length($this->{-text}); # Do line wrapping if needed and store the lines # to display in -scr_lines. Compute the x- and # y-position of the cursor in the text. my $lines = []; my ($xpos, $ypos, $trackpos) = (undef, 0, 0); foreach my $line (@$lines_src) { my $add = []; if ($this->{-wrapping}) { $add = $this->text_wrap($line, $this->canvaswidth, WORDWRAP); } else { $add = [$line]; } push @$lines, @$add; unless (defined $xpos) { foreach (@$add) { my $newtrackpos = $trackpos + length($_); if ( $this->{-pos} < $newtrackpos ) { $xpos = length(substr($_, 0, ($this->{-pos}-$trackpos))); } $trackpos = $newtrackpos; last if defined $xpos; $ypos++; } } } $this->{-scr_lines} = $lines; unless ($this->{-readonly}) { $this->{-xpos} = $xpos; $this->{-ypos} = $ypos; } # ---------------------------------------------------------------------- # Handle vertical scrolling of the screen # ---------------------------------------------------------------------- # Scroll down if needed. if ( ($this->{-ypos}-$this->{-yscrpos}) >= $this->canvasheight ) { $this->{-yscrpos} = $this->{-ypos} - $this->canvasheight + 1; } # Scroll up if needed. elsif ( $this->{-ypos} < $this->{-yscrpos} ) { $this->{-yscrpos} = $this->{-ypos}; } # Check bounds. $this->{-yscrpos} = 0 if $this->{-yscrpos} < 0; $this->{-yscrpos} = @$lines if $this->{-yscrpos} > @$lines; # ---------------------------------------------------------------------- # Handle horizontal scrolling of the screen # ---------------------------------------------------------------------- # If wrapping is enabled, then check for horizontal scrolling. # Else make the -xscrpos fixed to 0. unless ($this->{-readonly}) { unless ($this->{-wrapping}) { my $realxpos = $this->getrealxpos; # If overflows have to be shown, the cursor may not # be set to the first or the last position of the # screen. my $wrapborder = (not $this->{-wrapping} and $this->{-showoverflow}) ? 1 : 0; # Scroll left if needed. if ($realxpos < $wrapborder) { while ($realxpos < ($wrapborder + int($this->canvaswidth/3)) and $this->{-xscrpos} > 0) { $this->{-xscrpos}--; $realxpos = $this->getrealxpos; } } # Scroll right if needed. if ($realxpos > ($this->canvaswidth - 1 - $wrapborder)) { while ($realxpos > 2*int($this->canvaswidth/3) ) { $this->{-xscrpos}++; $realxpos = $this->getrealxpos; } } } else { $this->{-xscrpos} = 0; } } # Check bounds. $this->{-xscrpos} = 0 if $this->{-xscrpos} < 0; $this->{-xscrpos} = $this->{-xpos} if $this->{-xscrpos} > $this->{-xpos}; # ---------------------------------------------------------------------- # Layout horizontal scrollbar. # ---------------------------------------------------------------------- if (($this->{-hscrollbar} and not $this->{-wrapping}) or $this->{-readonly}) { my $longest_line = $this->number_of_columns; $this->{-hscrolllen} = $longest_line + 1; $this->{-hscrollpos} = $this->{-xscrpos}; } else { $this->{-hscrolllen} = 0; $this->{-hscrollpos} = 0; } # ---------------------------------------------------------------------- # Layout vertical scrollbar # ---------------------------------------------------------------------- if ($this->{-vscrollbar} or $this->{-readonly}) { $this->{-vscrolllen} = @{$this->{-scr_lines}}; $this->{-vscrollpos} = $this->{-yscrpos}; } else { $this->{-vscrolllen} = 0; $this->{-vscrollpos} = 0; } return $this; } sub draw_text(;$) { my $this = shift; my $no_doupdate = shift || 0; return $this if $Curses::UI::screen_too_small; # Return immediately if this object is hidden. return $this if $this->hidden; # Turn on underlines and fill the screen with lines # if neccessary. if ($this->{-showlines} or $this->{-reverse}) { $this->{-canvasscr}->attron(A_UNDERLINE) if ($this->{-showlines});; $this->{-canvasscr}->attron(A_REVERSE) if ($this->{-reverse}); for my $y (0..$this->canvasheight-1) { $this->{-canvasscr}->addstr($y, 0, " "x($this->canvaswidth)); } } # Draw the text. for my $id (0 .. $this->canvasheight - 1) { # Let there be color if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg}); $this->{-canvasscr}->attron(COLOR_PAIR($pair)); } if (defined $this->{-search_highlight} and $this->{-search_highlight} == ($id+$this->{-yscrpos})) { $this->{-canvasscr}->attron(A_REVERSE) if (not $this->{-reverse}); $this->{-canvasscr}->attroff(A_REVERSE) if ($this->{-reverse}); } else { $this->{-canvasscr}->attroff(A_REVERSE) if (not $this->{-reverse}); $this->{-canvasscr}->attron(A_REVERSE) if ($this->{-reverse}); } my $l = $this->{-scr_lines}->[$id + $this->{-yscrpos}]; if (defined $l) { # Get the part of the line that is in view. my $inscreen = ''; my $fromxscr = ''; if ($this->{-xscrpos} < length($l)) { $fromxscr = substr($l, $this->{-xscrpos}, length($l)); $inscreen = ($this->text_wrap( $fromxscr, $this->canvaswidth, NO_WORDWRAP))->[0]; } # Masquerading of password fields. if ($this->{-singleline} and defined $this->{-password}) { # Don't masq the endspace which we # added ourselves. $inscreen =~ s/\s$//; # Substitute characters. $inscreen =~ s/[^\n]/$this->{-password}/g; } # Clear line. $this->{-canvasscr}->addstr( $id, 0, " "x$this->canvaswidth ); # Strip newline and replace by diamond character # if the showhardreturns option is on. if ($inscreen =~ /\n/) { $inscreen =~ s/\n//; $this->{-canvasscr}->addstr($id, 0, $inscreen); if ($this->{-showhardreturns}) { if ($this->root->compat) { $this->{-canvasscr}->addch($id, scrlength($inscreen),'@'); } else { $this->{-canvasscr}->attron(A_ALTCHARSET); $this->{-canvasscr}->addch($id, scrlength($inscreen),'`'); $this->{-canvasscr}->attroff(A_ALTCHARSET); } } } else { $this->{-canvasscr}->addstr($id, 0, $inscreen); } # Draw overflow characters. if (not $this->{-wrapping} and $this->{-showoverflow}) { $this->{-canvasscr}->addch($id, $this->canvaswidth-1, '$') if $this->canvaswidth < scrlength($fromxscr); $this->{-canvasscr}->addch($id, 0, '$') if $this->{-xscrpos} > 0; } } else { last; } } # Move the cursor. # Take care of TAB's if ($this->{-readonly}) { $this->{-canvasscr}->move( $this->canvasheight-1, $this->canvaswidth-1 ); } else { my $l = $this->{-scr_lines}->[$this->{-ypos}]; my $precursor = substr( $l, $this->{-xscrpos}, $this->{-xpos} - $this->{-xscrpos} ); my $realxpos = scrlength($precursor); $this->{-canvasscr}->move( $this->{-ypos} - $this->{-yscrpos}, $realxpos ); } $this->{-canvasscr}->attroff(A_UNDERLINE) if $this->{-showlines}; $this->{-canvasscr}->attroff(A_REVERSE) if $this->{-reverse}; $this->{-canvasscr}->noutrefresh(); doupdate() unless $no_doupdate; return $this; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; $this->SUPER::draw(1) or return $this; $this->layout_content; $this->draw_text(1); doupdate() unless $no_doupdate; return $this; } sub event_onblur() { my $this = shift; $this->SUPER::event_onblur; # Set the cursor position to the startposition # if -homeonblur is set. if ($this->{-homeonblur}) { $this->cursor_to_home; $this->layout_content; } return $this; } sub event_keypress ($;) { my $this = shift; my $key = shift; # Reset the field that tracks if undoinfo has already # been saved or not. $this->resetsetundo(); # Pasting more than one char/line is possible. As long # as you do it at once (no other actions in between are # allowed). if (defined $this->{-prevkey} and $this->{-prevkey} ne $key) { $this->do_new_pastebuffer(1); } else { $this->do_new_pastebuffer(0); } # Backup, in case illegal input is done. my %backup = %{$this}; # Process bindings. my $ret = $this->process_bindings($key); # Did the widget loose focus, due to the keypress? return $this unless $this->{-focus}; # To upper or to lower? if ($this->{-toupper}) { $this->{-text} = uc $this->{-text}; } elsif ($this->{-tolower}) { $this->{-text} = lc $this->{-text}; } # Check for illegal input. my $is_illegal = 0; if ($this->{-maxlength}) { $is_illegal = 1 if length($this->{-text}) > $this->{-maxlength}; } if (not $is_illegal and defined $this->{-maxlines}) { my $lines = $this->split_to_lines($this->{-text}); $is_illegal = 1 if @$lines > $this->{-maxlines}; } if (not $is_illegal and defined $this->{-regexp}) { my $e = '$is_illegal = (not $this->{-text} =~ ' . $this->{-regexp} . ')'; eval $e; } if ($is_illegal) # Illegal input? Then restore and bail out. { while (my ($k,$v) = each %backup) { $this->{$k} = $v; } $this->dobeep(); } else { # Legal input? Redraw the text. $this->run_event('-onchange'); $this->draw(1); } # Save the current key. $this->{-prevkey} = $key; return $ret; } sub add_string($;) { my $this = shift; my $ch = shift; my @ch = split //, $ch; $ch = ''; foreach (@ch) { $ch .= $this->key_to_ascii($_); } $this->set_undoinfo; PASTED: for (;;) { my $binding = $this->{-bindings}->{$ch}; $binding = 'add-string' unless defined $binding; if ($ch eq "-1") { last PASTED; } elsif ( $binding eq 'add-string' ) { substr($this->{-text}, $this->{-pos}, 0) = $ch; $this->{-pos} += length($ch); } elsif ( $binding eq 'newline' ) { $this->process_bindings($ch); } # Multiple characters at input? This is probably a # pasted string. Get it and process it. Don't do # special bindings, but only add-string and newline. $ch = $this->get_key(0); } $this->layout_content; $this->set_curxpos; return $this; } sub toggle_showoverflow() { my $this = shift; $this->{-showoverflow} = ! $this->{-showoverflow}; return $this; } sub toggle_wrapping() { my $this = shift; return $this->dobeep if $this->{-singleline}; $this->{-wrapping} = ! $this->{-wrapping}; $this->layout; return $this; } sub toggle_showhardreturns() { my $this = shift; return $this->dobeep if $this->{-singleline}; $this->{-showhardreturns} = ! $this->{-showhardreturns}; return $this; } sub cursor_right() { my $this = shift; # Handle cursor_right for read only mode. if ($this->{-readonly}) { return $this->dobeep unless defined $this->{-hscrolllen}; return $this->dobeep if $this->{-xscrpos} >= $this->{-hscrolllen} - $this->canvaswidth; $this->{-xscrpos} += 1; $this->{-hscrollpos} = $this->{-xscrpos}; $this->{-xpos} = $this->{-xscrpos}; return $this; } if ($this->{-pos} == length($this->{-text})) { $this->dobeep; } else { $this->{-pos}++; } $this->layout_content; $this->set_curxpos; return $this; } sub cursor_left() { my $this = shift; # Handle cursor_left for read only mode. if ($this->{-readonly}) { return $this->dobeep if $this->{-xscrpos} <= 0; $this->{-xscrpos} -= 1; $this->{-xpos} = $this->{-xscrpos}; return $this; } if ($this->{-pos} <= 0) { $this->dobeep; } else { $this->{-pos}--; } $this->layout_content; $this->set_curxpos; return $this; } sub set_curxpos() { my $this = shift; $this->{-curxpos} = $this->{-xpos}; return $this; } sub cursor_up(;$) { my $this = shift; shift; # stub for bindings handling. my $amount = shift || 1; return $this->dobeep if $this->{-singleline}; # Handle cursor_up for read only mode. if ($this->{-readonly}) { return $this->dobeep if $this->{-yscrpos} <= 0; $this->{-yscrpos} -= $amount; $this->{-yscrpos} = 0 if $this->{-yscrpos} < 0; $this->{-ypos} = $this->{-yscrpos}; return $this; } my $maymove = $this->{-ypos}; return $this->dobeep unless $maymove; $amount = $maymove if $amount > $maymove; my $l = $this->{-scr_lines}; $this->cursor_to_scrlinestart; $this->{-ypos} -= $amount; while ($amount) { my $idx = $this->{-ypos} + $amount - 1; my $line = $l->[$idx]; my $line_length = length($line); $this->{-pos} -= $line_length; $amount--; } $this->cursor_to_curxpos; return $this; } sub cursor_pageup() { my $this = shift; return $this->dobeep if $this->{-singleline}; $this->cursor_up(undef, $this->canvasheight - 1); return $this; } sub cursor_down($;) { my $this = shift; shift; # stub for bindings handling. my $amount = shift || 1; return $this->dobeep if $this->{-singleline}; # Handle cursor_down for read only mode. if ($this->{-readonly}) { my $max = @{$this->{-scr_lines}} - $this->canvasheight; return $this->dobeep if $this->{-yscrpos} >= $max; $this->{-yscrpos} += $amount; $this->{-yscrpos} = $max if $this->{-yscrpos} > $max; $this->{-ypos} = $this->{-yscrpos}; return $this; } my $l = $this->{-scr_lines}; my $maymove = (@$l-1) - $this->{-ypos}; return $this->dobeep unless $maymove; $amount = $maymove if $amount > $maymove; $this->cursor_to_scrlinestart; $this->{-ypos} += $amount; while ($amount) { my $idx = $this->{-ypos} - $amount; my $line = $l->[$idx]; my $line_length = length($line); $this->{-pos} += $line_length; $amount--; } $this->cursor_to_curxpos; return $this; } sub cursor_pagedown() { my $this = shift; return $this->dobeep if $this->{-singleline}; $this->cursor_down(undef, $this->canvasheight - 1); return $this; } sub cursor_to_home() { my $this = shift; if ($this->{-readonly}) { $this->{-xscrpos} = $this->{-xpos} = 0; $this->{-yscrpos} = $this->{-ypos} = 0; return $this; } $this->{-pos} = 0; $this->set_curxpos; return $this; } sub cursor_to_end() { my $this = shift; if ($this->{-readonly}) { $this->{-xscrpos} = $this->{-xpos} = 0; $this->{-yscrpos} = $this->{-ypos} = $this->{-vscrolllen}-$this->canvasheight; return $this; } $this->{-pos} = length($this->{-text}); $this->set_curxpos; return $this; } sub cursor_to_scrlinestart() { my $this = shift; # Key argument is set if called from binding. my $from_binding = shift; if ($this->{-readonly}) { $this->{-xscrpos} = $this->{-xpos} = 0; return $this; } $this->{-pos} -= $this->{-xpos}; $this->{-xpos} = 0; $this->set_curxpos if defined $from_binding; return $this; } sub cursor_to_scrlineend() { my $this = shift; my $from_binding = shift; if ($this->{-readonly}) { $this->{-xscrpos} = $this->{-xpos} = $this->{-hscrolllen} - $this->canvaswidth ; return $this; } my $newpos = $this->{-pos}; my $l = $this->{-scr_lines}; my $len = length($l->[$this->{-ypos}]) - 1; $newpos += $len - $this->{-xpos}; $this->{-pos} = $newpos; $this->layout_content; $this->set_curxpos if defined $from_binding; return $this; } sub cursor_to_linestart() { my $this = shift; # Move cursor back, until \n is found. That is # the previous line. Then go one position to the # right to find the start of the line. my $newpos = $this->{-pos}; for(;;) { last if $newpos <= 0; $newpos--; last if substr($this->{-text}, $newpos, 1) eq "\n"; } $newpos++ unless $newpos == 0; $newpos = length($this->{-text}) if $newpos > length($this->{-text}); $this->{-pos} = $newpos; $this->layout_content; return $this; } sub cursor_to_curxpos() { my $this = shift; my $right = $this->{-curxpos}; $right = 0 unless defined $right; my $len = length($this->{-scr_lines}->[$this->{-ypos}]) - 1; if ($right > $len) { $right = $len } $this->{-pos} += $right; $this->layout_content; return $this; } sub clear_line() { my $this = shift; $this->cursor_to_linestart; $this->delete_till_eol; return $this; } sub delete_line() { my $this = shift; return $this->dobeep if $this->{-singleline}; my $len = length($this->{-text}); if ($len == 0) { $this->dobeep; return $this; } $this->beep_off ->cursor_to_linestart ->delete_till_eol ->cursor_left ->delete_character ->cursor_right ->cursor_to_linestart ->set_curxpos ->beep_on; return $this; } sub delete_till_eol() { my $this = shift; $this->set_undoinfo; # Cursor is at newline. No action needed. return $this if substr($this->{-text}, $this->{-pos}, 1) eq "\n"; # Find the next newline. Delete the content up to that newline. my $pos = $this->{-pos}; for(;;) { $pos++; last if $pos >= length($this->{-text}); last if substr($this->{-text}, $pos, 1) eq "\n"; } $this->add_to_pastebuffer( substr($this->{-text}, $this->{-pos}, $pos - $this->{-pos}) ); substr($this->{-text}, $this->{-pos}, $pos - $this->{-pos}, ''); return $this; } sub delete_character() { my $this = shift; shift(); # stub for bindings handling. my $is_backward = shift; if ($this->{-pos} >= length($this->{-text})) { $this->dobeep; } else { $this->set_undoinfo; $this->add_to_pastebuffer( substr($this->{-text}, $this->{-pos}, 1), $is_backward ); substr($this->{-text}, $this->{-pos}, 1, ''), } return $this; } sub backspace() { my $this = shift; if ($this->{-pos} <= 0) { $this->dobeep; } else { $this->set_undoinfo; $this->{-pos}--; $this->delete_character(undef,1); $this->layout_content; $this->set_curxpos; } return $this; } sub newline() { my $this = shift; return $this->dobeep if $this->{-singleline}; $this->add_string("\n"); } sub mouse_button1($$$$;) { my $this = shift; my $event = shift; my $x = shift; my $y = shift; return unless $this->{-focusable}; # TODO: make this possible for multi line widgets. if ($this->{-singleline}) { $this->{-pos} = $this->{-xscrpos} + $x; $this->layout_content; $this->set_curxpos; } $this->focus(); return $this; } sub resetsetundo() { shift()->{-didsetundo} = 0} sub didsetundo() { shift()->{-didsetundo} } sub set_undoinfo() { my $this = shift; return $this if $this->didsetundo; push @{$this->{-undotext}}, $this->{-text}; push @{$this->{-undopos}}, $this->{-pos}; my $l = $this->{-undolevels}; if ($l and @{$this->{-undotext}} > $l) { splice(@{$this->{-undotext}}, 0, @{$this->{-undotext}}-$l, ()); splice(@{$this->{-undopos}}, 0, @{$this->{-undopos}}-$l, ()); } $this->{-didsetundo} = 1; return $this; } sub undo() { my $this = shift; if (@{$this->{-undotext}}) { my $text = pop @{$this->{-undotext}}; my $pos = pop @{$this->{-undopos}}; $this->{-text} = $text; $this->{-pos} = $pos; } return $this; } sub do_new_pastebuffer(;$) { my $this = shift; my $value = shift; $this->{-do_new_pastebuffer} = $value if defined $value; $this->{-pastebuffer} = '' unless defined $this->{-pastebuffer}; return $this->{-do_new_pastebuffer}; } sub clear_pastebuffer() { my $this = shift; $this->{-pastebuffer} = ''; return $this; } sub add_to_pastebuffer($;) { my $this = shift; my $add = shift; my $is_backward = shift || 0; $this->clear_pastebuffer if $this->do_new_pastebuffer; if ($is_backward) { $this->{-pastebuffer} = $add . $this->{-pastebuffer}; } else { $this->{-pastebuffer} .= $add; } $this->do_new_pastebuffer(0); return $this; } sub paste() { my $this = shift; if ($this->{-pastebuffer} ne '') { $this->add_string($this->{-pastebuffer}); } return $this; } sub readonly($;) { my $this = shift; my $readonly = shift; $this->{-readonly} = $readonly; if ($readonly) { my %mybindings = ( %basebindings, %viewbindings ); $this->{-bindings} = \%mybindings; $this->{-nocursor} = 1; } else { my %mybindings = ( %basebindings, %editbindings ); $this->{-bindings} = \%mybindings; $this->{-nocursor} = 0; } return $this; } sub get() {shift()->text} sub pos(;$) { my $this = shift; my $pos = shift; if (defined $pos) { $this->{-pos} = $pos; $this->layout_content; $this->intellidraw; return $this; } return $this->{-pos}; } sub text(;$) { my $this = shift; my $text = shift; if (defined $text) { $this->{-text} = $text; $this->layout_content; $this->intellidraw; return $this; } return $this->{-text}; } sub onChange(;$) { shift()->set_event('-onchange', shift()) } sub set_password_char { my ($this, $char) = @_; $char = substr($char, 0, 1) if defined $char; $this->{-password} = $char; } # ---------------------------------------------------------------------- # Routines for search support # ---------------------------------------------------------------------- sub number_of_lines() { @{shift()->{-scr_lines}} } sub number_of_columns() { my $this = shift; my $columns = 0; foreach (@{$this->{-scr_lines}}) { $columns = length($_) if length($_) > $columns; } return $columns; } sub getline_at_ypos($;) { shift()->{-scr_lines}->[shift()] } # # Color # sub set_color_fg { my $this = shift; $this->{-fg} = shift; $this->intellidraw; } sub set_color_bg { my $this = shift; $this->{-bg} = shift; $this->intellidraw; } 1; =pod =head1 NAME Curses::UI::TextEditor - Create and manipulate texteditor widgets =head1 CLASS HIERARCHY Curses::UI::Widget Curses::UI::Searchable | +----Curses::UI::TextEditor =head1 SYNOPSIS use Curses::UI; my $cui = new Curses::UI; my $win = $cui->add('window_id', 'Window'); my $editor = $win->add( 'myeditor', 'TextEditor', -vscrollbar => 1, -wrapping => 1, ); $editor->focus(); my $text = $editor->get(); =head1 DESCRIPTION Curses::UI::TextEditor is a widget that can be used to create a couple of different kinds of texteditors. These are: =over 4 =item * B This is a multi-line text editor with features like word-wrapping, maximum textlength and undo. =item * B The texteditor can be created as a single-line editor. Most of the features of the default texteditor will remain. Only the multi-line specific options will not be available (like moving up and down in the text). =item * B The texteditor can also be used in read only mode. In this mode, the texteditor will function as a text viewer. The user can walk through the text and search trough it. =back See exampes/demo-Curses::UI::TextEditor in the distribution for a short demo of these. =head1 STANDARD OPTIONS B<-parent>, B<-x>, B<-y>, B<-width>, B<-height>, B<-pad>, B<-padleft>, B<-padright>, B<-padtop>, B<-padbottom>, B<-ipad>, B<-ipadleft>, B<-ipadright>, B<-ipadtop>, B<-ipadbottom>, B<-title>, B<-titlefullwidth>, B<-titlereverse>, B<-onfocus>, B<-onblur> For an explanation of these standard options, see L. =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item * B<-text> < TEXT > This sets the initial text for the widget to TEXT. =item * B<-pos> < CURSOR_POSITION > This sets the initial cursor position for the widget to CURSOR_POSITION. B<-pos> represents the character index within B<-text>. By default this option is set to 0. =item * B<-readonly> < BOOLEAN > The texteditor widget will be created as a read only texteditor (which is also called a textviewer) if BOOLEAN is true. By default BOOLEAN is false. =item * B<-singleline> < BOOLEAN > The texteditor widget will be created as a single line texteditor (which is also called a textentry) if BOOLEAN is true. By default BOOLEAN is false. =item * B<-wrapping> < BOOLEAN > If BOOLEAN is true, the texteditor will have text wrapping enabled. By default BOOLEAN is false. =item * B<-showlines> < BOOLEAN > If BOOLEAN is set to a true value, each editable line in the editor will show a line to type on. By default BOOLEAN is set to false. =item * B<-maxlength> < VALUE > This sets the maximum allowed length of the text to VALUE. By default VALUE is set to 0, which means that the text may be infinitely long. =item * B<-maxlines> < VALUE > This sets the maximum allowed number of lines for the text to SCALAR. By default VALUE is set to 0, which means that the text may contain an infinite number of lines. =item * B<-password> < CHARACTER > Instead of showing the real text in the widget, every character of the text will (on the screen) be replaced by CHARACTER. So creating a standard password field can be done by setting: -password => '*' =item * B<-regexp> < REGEXP > If characters are added to the texteditor, the new text will be matched against REGEXP. If the text does not match, the change will be denied. This can for example be used to force digit-only input on the texteditor: -regexp => '/^\d*$/' =item * B<-undolevels> < VALUE > This option determines how many undolevels should be kept in memory for the texteditor widget. By default 10 levels are kept. If this value is set to 0, the number of levels is infinite. =item * B<-showoverflow> < BOOLEAN > If BOOLEAN is true, the text in the texteditor will be padded by an overflow character ($) if there is text outside the screen (like 'pico' does). By default BOOLEAN is true. =item * B<-showhardreturns> < BOOLEAN > If BOOLEAN is true, hard returns will be made visible by a diamond character. By default BOOLEAN is false. =item * B<-homeonblur> < BOOLEAN > If BOOLEAN is set to a true value, the cursor will move to the start of the text if the widget loses focus. =item * B<-toupper> < BOOLEAN > If BOOLEAN is true, all entered text will be converted to uppercase. By default BOOLEAN is false. =item * B<-tolower> < BOOLEAN > If BOOLEAN is true, all entered text will be converted to lowercase. By default BOOLEAN is false. =item * B<-onchange> < CODEREF > This sets the onChange event handler for the texteditor widget. If the text is changed by typing, the code in CODEREF will be executed. It will get the widget reference as its argument. =item * B<-reverse> < BOOLEAN > Makes the text drawn in reverse font. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) =item * B ( ) =item * B ( BOOLEAN ) =item * B ( ) =item * B ( CODEREF ) =item * B ( CODEREF ) These are standard methods. See L for an explanation of these. =item * B ( [TEXT] ) If TEXT is defined, this will set the text of the widget to TEXT. To see the change, the widget needs to be redrawn by the B method. If TEXT is not defined, this method will return the current contents of the texteditor. =item * B ( ) This method will call B without any arguments, so it will return the contents of the texteditor. =item * B ( CODEREF ) This method can be used to set the B<-onchange> event handler (see above) after initialization of the texteditor. =item * B ( $char ) This method can be used to change the password property. The password character will be set to $char, or turned off in $char is undef. =item * B Toggles the -showhardreturns option. =item * B Toggles the -showoverflow option. =item * B Toggles the -wrapping option. =back =head1 DEFAULT BINDINGS There are different sets of bindings for each mode in which this widget can be used. =head2 All modes (editor, single line and read only) =over 4 =item * > Call the 'returreturnn' routine. This will have the widget loose its focus. =item * >, > Call the 'cursor-left' routine: move the cursor one position to the left. =item * >, > Call the 'cursor-right' routine: move the cursor one position to the right. =item * >, > Call the 'cursor-down' routine: move the cursor one line down. =item * >, > Call the 'cursor-up' routine: move the cursor one line up. =item * > Call the 'cursor-pageup' routine: move the cursor to the previous page. =item * > Call the 'cursor-pagedown' routine: move the cursor to the next page. =item * > Call the 'cursor-home' routine: go to the start of the text. =item * > Call the 'cursor-end' routine: go to the end of the text. =item * > Call the 'cursor-scrlinestart' routine: move the cursor to the start of the current line. =item * > Call the 'cursor-scrlineend' routine: move the cursor to the end of the current line. =item * > Call the 'toggle-wrapping' routine: toggle the -wrapping option of the texteditor. =item * > Call the 'toggle-showhardreturns' routine: toggle the -showhardreturns option of the texteditor. =item * > Call the 'toggle-showoverflow' routine: toggle the -showoverflow option of the texteditor. =back =head2 All edit modes (all but read only mode) =over 4 =item * >, > Call the 'delete-line' routine: Delete the current line. =item * > Call the 'delete-till-eol' routine: delete the text from the current cursor position up to the end of the current line. =item * > Call the 'clear-line' routine: clear the current line and move the cursor to the start of this line. =item * > Call the 'delete-character' routine: delete the character that currently is under the cursor. =item * > Call the 'backspace' routine: delete the character this is before the current cursor position. =item * > Call the 'undo' routine: undo the last change to the text, up to B<-undolevels> levels. =item * > Call the 'paste' routine: this will paste the last deleted text at the current cursor position. =item * > Call the 'add-string' routine: the character will be inserted in the text at the current cursor position. =back =head2 Only for the read only mode =over 4 =item * > Call the 'cursor-left' routine: move the cursor one position to the left. =item * > Call the 'cursor-right' routine: move the cursor one position to the right. =item * b<> Call the 'cursor-up' routine: move the cursor one line up. =item * b<> Call the 'cursor-down' routine: move the cursor one line down. =item * >, > Call the 'cursor-pagedown' routine: move the cursor to the next page. =item * >, > Call the 'cursor-pageup' routine: move the cursor to the previous page. =item * > Call the 'search-forward' routine. This will make a 'less'-like search system appear in the textviewer. A searchstring can be entered. After that the user can search for the next occurance using the 'n' key or the previous occurance using the 'N' key. =item * > Call the 'search-backward' routine. This will do the same as the 'search-forward' routine, only it will search in the opposite direction. =back =head1 SEE ALSO L, L L L, L =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. Curses-UI-0.9609/lib/Curses/UI/Tutorial.pod0000644000175000001440000001225111627564365017136 0ustar mdxiusers=head1 NAME Curses::UI::Tutorial - Tutorial for the Curses::UI framework =head1 Introduction The intention of this tutorial is a quick overview of Curses::UI and it's widgets. The target of this example is to write a simple text editor using the Curses::UI framework. =head1 First requirements In order to use Curses::UI start your program with "use Curses::UI;" and, as it is always a good idea, add "use strict" and the -w switch too. After that an instance of Curses::UI must be created. From now on, this instance will be called "the UI". You also want to redirect STDERR to a file (e.g. perl myscript.pl 2> debug.out), so output that does not come from Curses::UI doesn't clobber your display. You want fancy colors, so the option -color_support is set to a true value. #!/usr/bin/perl -w use strict; use Curses::UI; my $cui = new Curses::UI( -color_support => 1 ); =head1 Create a menu my @menu = ( { -label => 'File', -submenu => [ { -label => 'Exit ^Q', -value => \&exit_dialog } ] }, ); In order to describe the structure of a menu Curses::UI uses a rather ugly construct out of hash and arrayrefs. See Curses::UI::Menubar for details. What you do at this point is to create a Menubar with just one entry and one submenu. The entry is 'File' and the submenu is 'Exit'. The value of this menu item is a reference to a sub called exit_dialog. =head1 Dialogs sub exit_dialog() { my $return = $cui->dialog( -message => "Do you really want to quit?", -title => "Are you sure???", -buttons => ['yes', 'no'], ); exit(0) if $return; } The dialog method of Curses::UI gives us an easy and convenient way to create dialogs on the main screen. A dialog is a way to interact with the user in order to ask him a question or give him important information. This dialog is a more complex one, which asks the question whether or not you really want to exit. As the button for "yes" would return us a true value, you can easily exit on this return value. =head1 Add the Menubar my $menu = $cui->add( 'menu','Menubar', -menu => \@menu, -fg => "blue", ); To finally add the Menubar to our root object, you have to call the add method on the Curses UI object. You specify the internal name of the widget as the first argument, the widget type as the second argument (like Label, TextViewer, etc.) and the menu structure you created at the beginning as an array reference as third object. Because you want the Menubar to have a blue theme, you give him the -fg option "blue". There are a couple of colors you can use, see Curses::UI::Color for details. =head1 Add a window my $win1 = $cui->add( 'win1', 'Window', -border => 1, -y => 1, -bfg => 'red', ); There are only two types of object you can add to the Curses::UI root object: Menubars and Windows. All other widgets have to be inserted into a window. Of course you can add a Menubar to a window, but not vice versa ;-). The add method always has the same two first arguments: the internal name and the widget type. The internal name can be used to find an object. The method getobj takes this name and returns us the corresponding object out of the hierarchy. See Curses::UI for details. Again you want some fancy colors, so you tell the window to have a border, leave some space for the Menubar (-y => 1) and set the border foreground color to red. =head1 Add a widget my $texteditor = $win1->add("text", "TextEditor", -text => "Here is some text\n" . "And some more"); The next step is to add a useful widget to our new small Curses::UI app. Here you take a TextEditor widget which performs basic tasks as a text editor. You add some initial text to the widget to make it not seem that empty. =head1 Making keybindings $cui->set_binding(sub {$menu->focus()}, "\cX"); $cui->set_binding( \&exit_dialog , "\cQ"); You want to be able to focus the Menubar if you finished editing in the TextEditor widget. Therefore you set a binding to the focus function of the menu and the key sequence Control (specified by \c) combined with X. Now you can easily return to the menu after editing. Because it is easier to have a shortcut for closing the application you add a binding for the sequence Control-Q to our nice exit_dialog method. =head1 The final steps $texteditor->focus(); $cui->mainloop(); You want to start editing directly. Therefore you set the initial focus on the TextEditor by calling it's focus method directly. The last thing you got to do is to tell Curses that it now contoles the program flow by starting it's MainLoop. =head1 You're done! You have built a genuine Curses::UI application! Not that it is a very useful one, but who cares? Now try out if it works like you think it should. The complete source code of this application is located in the examples directory of the distribution (examples/tutorial.pl). Now you can enhance this application to become a full featured editor like Emacs :-) =head1 Author 2003-2004 (c) by Marcus Thiesen (marcus@cpan.org) All rights reserved This Tutorial is licensed under the same terms as perl itself. If you have some additions to this tutorial feel free to send me a mail. Curses-UI-0.9609/lib/Curses/UI/Widget.pm0000644000175000001440000015022411630213323016366 0ustar mdxiusers# ---------------------------------------------------------------------- # Curses::UI::Widget # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # Currently maintained by Marcus Thiesen # e-mail: marcus@cpan.thiesenweb.de # ---------------------------------------------------------------------- package Curses::UI::Widget; use strict; use Carp qw(confess); use Term::ReadKey; use Curses; use Curses::UI::Common; require Exporter; use vars qw( $VERSION @ISA @EXPORT ); $VERSION = '1.12'; @ISA = qw( Curses::UI::Common Exporter ); @EXPORT = qw( height_by_windowscrheight width_by_windowscrwidth process_padding loose_focus lose_focus ); sub new () { my $class = shift; my %userargs = @_; keys_to_lowercase(\%userargs); my %args = ( -parent => undef, # the parent object -x => 0, # horizontal position (rel. to -parent) -y => 0, # vertical position (rel. to -parent) -width => undef, # horizontal size -height => undef, # vertical size -border => 0, # add a border? -sbborder => 0, # add square bracket border? -nocursor => 0, # Show a cursor? -titlefullwidth => 0, # full width for title? -titlereverse => 1, # reverse chars for title? -title => undef, # A title to add to the widget (only for # -border = 1) # padding outside widget -pad => undef, # all over padding -padright => undef, # free space on the right side -padleft => undef, # free space on the left side -padtop => undef, # free space above -padbottom => undef, # free space below # padding inside widget -ipad => undef, # all over padding -ipadright => undef, # free space on the right side -ipadleft => undef, # free space on the left side -ipadtop => undef, # free space above -ipadbottom => undef, # free space below # scrollbars -vscrollbar => 0, # vert. scrollbar (top/bottom) -vscrolllen => 0, # total number of rows -vscrollpos => 0, # current row position -hscrollbar => 0, # hor. scrollbar (left/right) -hscrolllen => 0, # total number of columns -hscrollpos => 0, # current column position -onfocus => undef, # onFocus event handler -onblur => undef, # onBlur event handler -intellidraw => 1, # Support intellidraw()? -focusable => 1, # This widget can get focus -htmltext => 1, # Recognize HTML tags in drawn text #user data -userdata => undef, #user internal data #color # Border -bfg => -1, -bbg => -1, # Scrollbar -sfg => -1, -sbg => -1, # Titlebar -tfg => -1, -tbg => -1, %userargs, -focus => 0, # has the widget focus? ); # Allow the value -1 for using the full width and/or # height for the widget. $args{-width} = undef if defined $args{-width} and $args{-width} == -1; $args{-height} = undef if defined $args{-height} and $args{-height} == -1; &Curses::UI::fatalerror( "Missing or illegal parameter: -parent\n" . "while creating " . caller() . "object" ) unless defined $args{-parent} and ref $args{-parent}; # Allow a square bracket border only if # a normal border (-border) is disabled. $args{-sbborder} = 0 if $args{-sbborder} and $args{-border}; # Bless you! (so we can call the layout function). my $this = bless \%args, $class; $this->layout; if ($Curses::UI::ncurses_mouse) { $this->set_mouse_binding(\&mouse_button1, BUTTON1_CLICKED()) unless $this->{-mousebindings}->{BUTTON1_CLICKED()}; } return $this; } sub DESTROY() { my $this = shift; $this->delete_subwindows(); } sub userdata { my $this = shift; if (defined $_[0]) { $this->{-userdata} = $_[0]; } return $this->{-userdata}; } sub focusable(;$) { my $this = shift; my $focusable = shift; if (defined $focusable) { $this->accessor('-focusable', $focusable); # Let the parent find another widget to focus # if this widget is not focusable anymore. if ($this->{-focus} and not $focusable) { $this->parent->focus($this); } } return $this->{-focusable}; } sub layout() { cbreak(); my $this = shift; return if $Curses::UI::screen_too_small; $this->process_padding; # ------------------------------------------------------- # Compute the space that we have for the widget. # ------------------------------------------------------- $this->{-parentdata} = $this->{-parent}->windowparameters; foreach (qw(x y)) { if (not defined $this->{"-$_"}) {$this->{"-$_"} = 0} if ($this->{"-$_"} >= 0) { $this->{"-real$_"} = $this->{"-$_"}; } else { my $pv = ($_ eq 'x' ? '-w' : '-h'); $this->{"-real$_"} = $this->{-parentdata}->{$pv} + $this->{"-$_"} + 1; } } my $w = $this->{-parentdata}->{-w}; my $h = $this->{-parentdata}->{-h}; my $cor_h = $this->{-y}; $cor_h = abs($this->{-y}+1) if $cor_h < 0; my $cor_w = $this->{-x}; $cor_w = abs($this->{-x}+1) if $cor_w < 0; my $avail_h = $h - $cor_h; my $avail_w = $w - $cor_w; # Compute horizontal widget size and adjust if neccessary. my $min_w = ($this->{-border} ? 2 : 0) + ($this->{-sbborder} ? 2 : 0) + (defined $this->{-vscrollbar} ? 1 : 0) + $this->{-padleft} + $this->{-padright}; my $width = (defined $this->{-width} ? $this->{-width} : $avail_w); $width = $min_w if $width < $min_w; $width = $avail_w if $width > $avail_w; # Compute vertical widget size and adjust if neccessary. my $min_h = ($this->{-border} ? 2 : 0) + ($this->{-hscrollbar} ? 1 : 0) + (defined $this->{-hscrollbar} ? 1 : 0) + $this->{-padtop} + $this->{-padbottom}; my $height = (defined $this->{-height} ? $this->{-height} : $avail_h); $height = $min_h if $height < $min_h; $height = $avail_h if $height > $avail_h; # Check if the widget fits in the window. if ($width > $avail_w or $height > $avail_h or $width == 0 or $height == 0) { $Curses::UI::screen_too_small++; return $this; } $this->{-w} = $width; $this->{-h} = $height; if ($this->{-x} < 0) { $this->{-realx} -= $width } if ($this->{-y} < 0) { $this->{-realy} -= $height } # Take care of padding for the border. $this->{-bw} = $width - $this->{-padleft} - $this->{-padright}; $this->{-bh} = $height - $this->{-padtop} - $this->{-padbottom}; $this->{-bx} = $this->{-realx} + $this->{-padleft}; $this->{-by} = $this->{-realy} + $this->{-padtop}; # ------------------------------------------------------- # Create a window for the widget border, if a border # and/or scrollbars are wanted. # ------------------------------------------------------- if ($this->{-border} or $this->{-sbborder} or $this->{-vscrollbar} or $this->{-hscrollbar}) { my @args = ($this->{-bh}, $this->{-bw}, $this->{-by}, $this->{-bx}); $this->{-borderscr} = $this->{-parent}->{-canvasscr}->derwin(@args); unless (defined $this->{-borderscr}) { $Curses::UI::screen_too_small++; return $this; } } # ------------------------------------------------------- # Create canvas screen region # ------------------------------------------------------- $this->{-sh} = $this->{-bh} - $this->{-ipadtop} - $this->{-ipadbottom} - ($this->{-border}? 2 : 0) - (not $this->{-border} and $this->{-hscrollbar} ? 1 : 0); $this->{-sw} = $this->{-bw} - $this->{-ipadleft} - $this->{-ipadright} - ($this->{-border}? 2 : 0) - ($this->{-sbborder}? 2 : 0) - (not $this->{-border} and $this->{-vscrollbar} ? 1 : 0); $this->{-sy} = $this->{-by} + $this->{-ipadtop} + ($this->{-border}?1:0) + (not $this->{-border} and $this->{-hscrollbar} eq 'top' ? 1 : 0); $this->{-sx} = $this->{-bx} + $this->{-ipadleft} + ($this->{-border}?1:0) + ($this->{-sbborder}?1:0) + (not $this->{-border} and $this->{-vscrollbar} eq 'left' ? 1 : 0); # Check if there is room left for the screen. if ($this->{-sw} <= 0 or $this->{-sh} <= 0) { $Curses::UI::screen_too_small++; return $this; } # Create a window for the data. my @args = ($this->{-sh}, $this->{-sw}, $this->{-sy}, $this->{-sx}); $this->{-canvasscr} = $this->{-parent}->{-canvasscr}->derwin(@args); unless (defined $this->{-canvasscr}) { $Curses::UI::screen_too_small++; return $this; } unless (defined $this->{-borderscr}) { $this->{-bw} = $this->{-sw}; $this->{-bh} = $this->{-sh}; $this->{-bx} = $this->{-sx}; $this->{-by} = $this->{-sy}; } return $this; } sub process_padding($;) { my $this = shift; # Process the padding arguments. foreach my $type ('-pad','-ipad') { if (defined $this->{$type}) { foreach my $side ('right','left','top','bottom') { $this->{$type . $side} = $this->{$type} unless defined $this->{$type . $side}; } } } foreach my $type ('-pad','-ipad') { foreach my $side ('right','left','top','bottom') { $this->{$type . $side} = 0 unless defined $this->{$type . $side}; } } } sub width_by_windowscrwidth($@) { my $width = shift || 0; $width = shift if ref $width; # make $this->width... possible. my %args = @_; $width += 2 if $args{-border}; # border $width += 2 if $args{-sbborder}; # sbborder $width += 1 if (not $args{-border} and # scrollbar and no border not $args{-sbborder} and $args{-vscrollbar}); foreach my $t ("-ipad", "-pad") # internal + external padding { if ($args{$t}) { $width += 2*$args{$t}; } else { $width += $args{$t . "left"} if defined $args{$t . "left"}; $width += $args{$t . "right"} if defined $args{$t . "right"}; } } return $width; } sub height_by_windowscrheight($@) { my $height = shift || 0; $height = shift if ref $height; # make $this->height... possible. my %args = @_; $height += 2 if $args{-border}; # border $height += 1 if (not $args{-border} and $args{-hscrollbar}); foreach my $t ("-ipad", "-pad") # internal + external padding { if ($args{$t}) { $height += 2*$args{$t}; } else { $height += $args{$t . "top"} if defined $args{$t . "top"}; $height += $args{$t . "bottom"} if defined $args{$t . "bottom"}; } } return $height; } sub width { shift->{-w} } sub height { shift->{-h} } sub borderwidth { shift->{-bw} } sub borderheight { shift->{-bh} } sub canvaswidth { shift->{-sw} } sub canvasheight { shift->{-sh} } sub title ($;) { my $this = shift; my $title = shift; if (defined $title) { $this->{-title} = $title; $this->intellidraw; } return $this->{-title} } sub windowparameters() { my $this = shift; my $scr = shift; $scr = "-canvasscr" unless defined $scr; my $s = $this->{$scr}; my ($x,$y,$w,$h); $s->getbegyx($y, $x); $s->getmaxyx($h, $w); return { -w => $w, -h => $h, -x => $x, -y => $y, }; } # # Actually, the focus is not loose but the widget should # lose the focus: sub lose_focus() { my $this = shift; $this->loose_focus(@_); } sub loose_focus() { my $this = shift; my $key = shift; # The focus change will draw $this anyhow and this # will reset the schedule if somewhere in the middle of # a binding routine loose_focus() is called (else # first the focus would shift and after that $this # would be redrawn). # $this->schedule_draw(0); if ($this->{-has_modal_focus}) { $this->{-has_modal_focus} = 0; } else { my $parent = $this->parent; # If $this is not focused anymore, then it most probably # has shifted focus itself using a callback routine. # In that case, do not go to the next or previous object, # but honour the current focus_path. # if ($this->root->focus_path(-1) ne $this) { return $this; } if (defined $key and $key eq KEY_BTAB()) { $this->parent->focus_prev(); } else { $this->parent->focus_next(); } } return $this; } sub focus() { my $this = shift; # Let the parent focus this object. my $parent = $this->parent; $parent->focus($this) if defined $parent; $this->draw(1) if ($this->root->overlapping); return $this; } sub modalfocus () { my $this = shift; # "Fake" focus for this object. $this->{-has_modal_focus} = 1; $this->focus; $this->draw; # Event loop ((too?) much like Curses::UI->mainloop) while ( $this->{-has_modal_focus} ) { $this->root->do_one_event($this); } $this->{-focus} = 0; $this->{-has_modal_focus} = 0; return $this; } sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; # Return immediately if this object is hidden of if # the screen is currently too small. return if $Curses::UI::screen_too_small; return if $this->hidden; eval { curs_set(0) }; # not available on every system. # Clear the contents of the window. my $scr = defined $this->{-borderscr} ? $this->{-borderscr} : $this->{-canvasscr}; if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-fg}, $this->{-bg} ); $scr->bkgdset(COLOR_PAIR($pair) | 32) if (defined $scr and $pair); } return unless defined $scr; $scr->erase; $scr->noutrefresh(); # Do borderstuff? if (defined $this->{-borderscr}) { if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-bfg}, $this->{-bbg} ); $this->{-borderscr}->attron(COLOR_PAIR($pair)); } # Draw a border if needed. if ($this->{-sbborder}) # Square bracket ([,]) border { $this->{-borderscr}->attron(A_BOLD) if $this->{-focus}; my $offset = 1; $offset++ if $this->{-vscrollbar}; for my $y (0 .. $this->{-sh}-1) { my $rel_y = $y + $this->{-sy} - $this->{-by}; $this->{-borderscr}->addstr($rel_y, 0, '['); $this->{-borderscr}->addstr($rel_y, $this->{-bw}-$offset, ']'); } $this->{-borderscr}->attroff(A_BOLD) if $this->{-focus}; } elsif ($this->{-border}) # Normal border { $this->{-borderscr}->attron(A_BOLD) if $this->{-focus}; if ($this->root->compat) { $this->{-borderscr}->border( '|','|','-','-', '+','+','+','+' ); } else { $this->{-borderscr}->box(ACS_VLINE, ACS_HLINE); } $this->{-borderscr}->attroff(A_BOLD) if $this->{-focus}; # Draw a title if needed. if (defined $this->{-title}) { if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-tfg}, $this->{-tbg} ); $this->{-borderscr}->attron(COLOR_PAIR($pair)); } $this->{-borderscr}->attron(A_REVERSE) if $this->{-titlereverse}; if ($this->{-titlefullwidth} and $this->{-titlereverse}) { $this->{-borderscr}->attron(A_BOLD); $this->{-borderscr}->addstr(0, 1, " "x($this->{-bw}-2)); $this->{-borderscr}->attroff(A_BOLD); } my $t = $this->{-title}; my $l = $this->{-bw}-4; if ($l < length($t)) { $t = substr($t, 0, $l) if $l < length($t); $t =~ s/.$/\$/; } $this->{-borderscr}->attron(A_BOLD); $this->{-borderscr}->addstr(0, 1, " $t "); $this->{-borderscr}->attroff(A_REVERSE); $this->{-borderscr}->attroff(A_BOLD); } } $this->draw_scrollbars(); $this->{-borderscr}->noutrefresh(); } doupdate() unless $no_doupdate; return $this; } sub draw_scrollbars() { my $this = shift; return $this unless defined $this->{-borderscr}; if ($this->{-vscrollbar} and defined $this->{-vscrolllen}) { # Compute the drawing range for the scrollbar. my $xpos = $this->{-vscrollbar} eq 'left' ? 0 : $this->borderwidth-1; my $ypos_min = $this->{-sy}-$this->{-by}; my $ypos_max = $ypos_min + $this->canvasheight - 1; my $scrlen = $ypos_max - $ypos_min + 1; my $actlen = $this->{-vscrolllen} ? int($scrlen * ($scrlen/($this->{-vscrolllen}))+0.5) : 0; $actlen = 1 if not $actlen and $this->{-vscrolllen}; my $actpos = ($this->{-vscrolllen} and $this->{-vscrollpos}) ? int($scrlen*($this->{-vscrollpos}/$this->{-vscrolllen})) + $ypos_min + 1 : $ypos_min; # Only let the marker be at the end if the # scrollpos is too. if ($this->{-vscrollpos}+$scrlen >= $this->{-vscrolllen}) { $actpos = $scrlen - $actlen + $ypos_min; } else { if ($actpos + $actlen >= $scrlen) { $actpos--; } } # Only let the marker be at the beginning if the # scrollpos is too. if ($this->{-vscrollpos} == 0) { $actpos = $ypos_min; } else { if ($this->{-vscrollpos} and $actpos <= 0) { $actpos = $ypos_min+1; } } # Draw the base of the scrollbar, in case # there is no border. $this->{-borderscr}->attron(A_BOLD) if $this->{-focus}; $this->{-borderscr}->move($ypos_min, $xpos); $this->{-borderscr}->vline(ACS_VLINE,$scrlen); if ($this->root->compat) { $this->{-borderscr}->vline('|',$scrlen); } else { $this->{-borderscr}->vline(ACS_VLINE,$scrlen); } $this->{-borderscr}->attroff(A_BOLD) if $this->{-focus}; if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-sfg}, $this->{-sbg} ); $this->{-borderscr}->attron(COLOR_PAIR($pair)); } # Should an active region be drawn? my $scroll_active = ($this->{-vscrolllen} > $scrlen); # Draw scrollbar base, in case there is # Draw active region. if ($scroll_active) { $this->{-borderscr}->attron(A_REVERSE); for my $i (0 .. $actlen-1) { $this->{-borderscr}->addch($i+$actpos,$xpos," "); } $this->{-borderscr}->attroff(A_REVERSE); } if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-bfg}, $this->{-bbg} ); $this->{-borderscr}->attron(COLOR_PAIR($pair)); } } if ($this->{-hscrollbar} and defined $this->{-hscrolllen}) { # Compute the drawing range for the scrollbar. my $ypos = $this->{-hscrollbar} eq 'top' ? 0 : $this->borderheight-1; my $xpos_min = $this->{-sx}-$this->{-bx}; my $xpos_max = $xpos_min + $this->canvaswidth - 1; my $scrlen = $xpos_max - $xpos_min + 1; my $actlen = $this->{-hscrolllen} ? int($scrlen * ($scrlen/($this->{-hscrolllen}))+0.5) : 0; $actlen = 1 if not $actlen and $this->{-hscrolllen}; my $actpos = ($this->{-hscrolllen} and $this->{-hscrollpos}) ? int($scrlen*($this->{-hscrollpos}/$this->{-hscrolllen})) + $xpos_min + 1 : $xpos_min; # Only let the marker be at the end if the # scrollpos is too. if ($this->{-hscrollpos}+$scrlen >= $this->{-hscrolllen}) { $actpos = $scrlen - $actlen + $xpos_min; } else { if ($actpos + $actlen >= $scrlen) { $actpos--; } } # Only let the marker be at the beginning if the # scrollpos is too. if ($this->{-hscrollpos} == 0) { $actpos = $xpos_min; } else { if ($this->{-hscrollpos} and $actpos <= 0) { $actpos = $xpos_min+1; } } # Draw the base of the scrollbar, in case # there is no border. $this->{-borderscr}->attron(A_BOLD) if $this->{-focus}; $this->{-borderscr}->move($ypos, $xpos_min); if ($this->root->compat) { $this->{-borderscr}->hline('-',$scrlen); } else { $this->{-borderscr}->hline(ACS_HLINE,$scrlen); } $this->{-borderscr}->attroff(A_BOLD) if $this->{-focus}; # Should an active region be drawn? if ($Curses::UI::color_support) { my $co = $Curses::UI::color_object; my $pair = $co->get_color_pair( $this->{-sfg}, $this->{-sbg} ); $this->{-borderscr}->attron(COLOR_PAIR($pair)); } my $scroll_active = ($this->{-hscrolllen} > $scrlen); # Draw active region. if ($scroll_active) { $this->{-borderscr}->attron(A_REVERSE); for my $i (0 .. $actlen-1) { $this->{-borderscr}->addch($ypos, $i+$actpos," "); } $this->{-borderscr}->attroff(A_REVERSE); } } return $this; } sub beep_on() { my $this = shift; $this->{-nobeep} = 0; return $this } sub beep_off() { my $this = shift; $this->{-nobeep} = 1; return $this } sub dobeep() { my $this = shift; beep() unless $this->{-nobeep}; return $this; } # TODO: work out hiding of objects. sub hidden() { shift()->{-hidden} } sub hide() { shift()->{-hidden} = 1 } sub show() { shift()->{-hidden} = 0 } sub intellidraw(;$) { my $this = shift; if ( $this->{-intellidraw} and not $this->hidden and $this->in_topwindow ) { $this->draw(1); } return $this; } sub delete_subwindows() { my $this = shift; delete $this->{-scr}; foreach my $win (qw(-borderscr -canvasscr)) { if (defined $this->{$win}) { $this->{$win}->delwin; delete $this->{$win}; } } } sub parentwindow() { my $object = shift; until (not defined $object or $object->isa('Curses::UI::Window')) { $object = $object->parent } return $object; } sub in_topwindow() { my $this = shift; # Get the parent window of this widget. my $win = $this->parentwindow(); return unless defined $win; # A modal window should always be the topwindow. return 1 if $win->{-has_modal_focus}; # Get the current focus path (the list of objects # from the Curses::UI root up which currently # have the focus). Strip non Window object from # it, to find the topmost window. my @path = $this->root->focus_path; while (defined $path[-1] and not $path[-1]->isa('Curses::UI::Window')) { pop @path; } # Check if the parent window is on top. return (@path and ($win eq $path[-1])); } # ---------------------------------------------------------------------- # Binding # ---------------------------------------------------------------------- sub clear_binding($;) { my $this = shift; my $binding = shift; my @delete = (); while (my ($k,$v) = each %{$this->{-bindings}}) { push @delete, $k if $v eq $binding; } foreach (@delete) { delete $this->{-bindings}->{$_}; } return $this; } sub set_routine($$;) { my $this = shift; my $binding = shift; my $routine = shift; $this->{-routines}->{$binding} = $routine; return $this; } sub set_binding($@) { my $this = shift; my $routine = shift; my @keys = @_; # Create a routine entry if the routine that was # passed is a code reference instead of a # routine name. if (ref $routine eq 'CODE') { my $name = "__routine_$routine"; $this->set_routine($name, $routine); $routine = $name; } $this->root->fatalerror("set_binding(): $routine: no such routine") unless defined $this->{-routines}->{$routine}; foreach my $key (@keys) { $this->{-bindings}->{$key} = $routine; } return $this; } sub set_mouse_binding($@) { my $this = shift; my $routine = shift; my @mouse_events = @_; # Create a routine entry if the routine that was # passed is a code reference instead of a # routine name. if (ref $routine eq 'CODE') { my $name = "__routine_$routine"; $this->set_routine($name, $routine); $routine = $name; } $this->root->fatalerror("set_binding(): $routine: no such routine") unless defined $this->{-routines}->{$routine}; foreach my $mouse_event (@mouse_events) { $this->{-mousebindings}->{$mouse_event} = $routine; } return $this; } sub schedule_draw(;$) { shift()->accessor('-schedule_draw', shift()) } sub process_bindings($;$@) { my $this = shift; my $key = shift; my $is_mouse_event = shift || 0; my @extra = @_; # Reset draw schedule. $this->schedule_draw(0); # Find the binding to use. my $binding; if ($is_mouse_event) { $binding = $this->{-mousebindings}->{$key->{-bstate}}; if (not defined $binding) { # Check for default routine. $binding = $this->{-mousebindings}->{''}; } } else { $binding = $this->{-bindings}->{$key}; if (not defined $binding) { # Check for default routine. $binding = $this->{-bindings}->{''}; } } if (defined $binding) { my $return = $this->do_routine($binding, $key, @extra); # Redraw if draw schedule is set. $this->intellidraw if $this->schedule_draw; return $return; } else { return 'DELEGATE'; } } sub do_routine($;$) { my $this = shift; my $binding = shift; my @arguments = @_; # Find the routine to call. my $routine = $this->{-routines}->{$binding}; if (defined $routine) { if (ref $routine eq 'CODE') { my $return = $routine->($this, @arguments); return $return; } else { return $routine; } } else { $this->root->fatalerror( "No routine defined for keybinding \"$binding\"!" ); } } sub onFocus($;$) { shift()->set_event('-onfocus', shift()) } sub onBlur($;$) { shift()->set_event('-onblur', shift()) } sub event_onfocus() { my $this = shift; # Let the parent find another widget to focus # if this widget is not focusable. unless ($this->focusable) { return $this->parent->focus($this); } $this->{-focus} = 1; $this->run_event('-onfocus'); # Set cursor mode my $show_cursor = $this->{-nocursor} ? 0 : 1; $this->root->cursor_mode($show_cursor); $this->draw(1) if (not $this->root->overlapping); return $this; } sub event_onblur() { my $this = shift; $this->{-focus} = 0; $this->run_event('-onblur'); $this->draw(1) if (not $this->root->overlapping); return $this; } sub event_keypress($;) { my $this = shift; my $key = shift; $this->process_bindings($key); } sub event_mouse($;) { my $this = shift; my $MEVENT = shift; my $winp = $this->windowparameters; my $abs_x = $MEVENT->{-x} - $winp->{-x}; my $abs_y = $MEVENT->{-y} - $winp->{-y}; $this->process_bindings($MEVENT, 1, $abs_x, $abs_y); } sub mouse_button1($$$$;) { my $this = shift; my $event = shift; my $x = shift; my $y = shift; $this->focus() if not $this->{-focus} and $this->focusable; } # ---------------------------------------------------------------------- # Event handling # ---------------------------------------------------------------------- sub clear_event($;) { my $this = shift; my $event = shift; $this->set_event($event, undef); return $this; } sub set_event($;$) { my $this = shift; my $event = shift; my $callback = shift; if (defined $callback) { if (ref $callback eq 'CODE') { $this->{$event} = $callback; } else { $this->root->fatalerror( "$event callback for $this " . "($callback) is no CODE reference" ); } } else { $this->{$event} = undef; } return $this; } sub run_event($;) { my $this = shift; my $event = shift; my $callback = $this->{$event}; if (defined $callback) { if (ref $callback eq 'CODE') { return $callback->($this); } else { $this->root->fatalerror( "$event callback for $this " . "($callback) is no CODE reference" ); } } return; } ### ### Color attribute functions ### sub set_color_fg{ my $this = shift; $this->{-fg} = shift; $this->intellidraw; } sub set_color_bg{ my $this = shift; $this->{-bg} = shift; $this->intellidraw; } sub set_color_tfg{ my $this = shift; $this->{-tfg} = shift; $this->intellidraw; } sub set_color_tbg{ my $this = shift; $this->{-tbg} = shift; $this->intellidraw; } sub set_color_bfg{ my $this = shift; $this->{-bfg} = shift; $this->intellidraw; } sub set_color_bbg{ my $this = shift; $this->{-bbg} = shift; $this->intellidraw; } sub set_color_sfg{ my $this = shift; $this->{-sfg} = shift; $this->intellidraw; } sub set_color_sbg{ my $this = shift; $this->{-sbg} = shift; $this->intellidraw; } package Curses::UI::ContainerWidget; # Not special at all. This class is especially used as a flag for # container based widgets, so that we can detect these using # $object->isa('Curses::UI::ContainerWidget'). use Curses::UI::Container; use Curses::UI::Widget; use vars qw( @ISA $VERSION ); $VERSION = '1.10'; @ISA = qw( Curses::UI::Container Curses::UI::Widget ); sub new () { shift()->SUPER::new(@_) }; 1; =pod =head1 NAME Curses::UI::Widget - The base class for all widgets =head1 CLASS HIERARCHY Curses::UI::Widget - base class =head1 SYNOPSIS This class is not used directly by somebody who is building an application using Curses::UI. It's a base class that is expanded by the Curses::UI widgets. See WIDGET STRUCTURE below for a basic widget framework. use Curses::UI::Widget; my $widget = new Curses::UI::Widget( -width => 15, -height => 5, -border => 1, ); =head1 STANDARD OPTIONS The standard options for (most) widgets are the options that are enabled by this class. So this class doesn't really have standard options. =head1 WIDGET-SPECIFIC OPTIONS =head2 GENERAL: =over 4 =item * B<-parent> < OBJECTREF > This option specifies parent of the object. This parent is the object (Curses::UI, Window, Widget(descendant), etc.) in which the widget is drawn. =item * B<-intellidraw> < BOOLEAN > If BOOLEAN has a true value (which is the default), the B method (see below) will be suported. This option is mainly used in widget building. =item * B<-userdata> < SCALAR > This option specifies a user data that can be retrieved with the B() method. It is useful to store application's internal data that otherwise would not be accessible in callbacks. =item * B<-border> < BOOLEAN > Each widget can be drawn with or without a border. To enable the border use a true value and to disable it use a false value for BOOLEAN. The default is not to use a border. =item * B<-sbborder> < BOOLEAN > If no border is used, a square bracket border may be used. This is a border which is constructed from '[' and ']' characters. This type of border is especially useful for single line widgets (like text entries and popup boxes). A square bracket border can only be enabled if -border is false. The default is not to use a square bracket border. =back =head2 POSITIONING: +---------------------------------------------------+ | parent ^ | | | | | y | | | | | v | | ^ | | | | | padtop | | | | | v | | +- TITLE -------+ | | | widget ^ | | | | | | | | | | | | |<--x--><--padleft-->|<----width---->|<--padright-->| | | | | | | | | | | | | height | | | | v | | | +---------------+ | | ^ | | | | | padbottom | | | | | v | +---------------------------------------------------+ =over 4 =item * B<-x> < VALUE > The x-position of the widget, relative to the parent. The default is 0. =item * B<-y> < VALUE > The y-position of the widget, relative to the parent. The default is 0. =item * B<-width> < VALUE > The width of the widget. If the width is undefined or -1, the maximum available width will be used. By default the widget will use the maximum available width. =item * B<-height> < VALUE > The height of the widget. If the height is undefined or -1, the maximum available height will be used. By default the widget will use the maximum available height. =back =head2 PADDING: =over 4 =item * B<-pad> < VALUE > =item * B<-padtop> < VALUE > =item * B<-padbottom> < VALUE > =item * B<-padleft> < VALUE > =item * B<-padright> < VALUE > With -pad you can specify the default padding outside the widget (the default value for -pad is 0). Using one of the -pad... options that have a direction in them, you can override the default padding. =item * B<-ipad> < VALUE > =item * B<-ipadtop> < VALUE > =item * B<-ipadbottom> < VALUE > =item * B<-ipadleft> < VALUE > =item * B<-ipadright> < VALUE > These are almost the same as the -pad... options, except these options specify the padding _inside_ the widget. Normally the available effective drawing area for a widget will be the complete area if no border is used or else the area within the border. =back =head2 TITLE: Remark: A title is drawn in the border of a widget. So a title will only be available if -border is true. =over 4 =item * B<-title> < TEXT > Set the title of the widget to TEXT. If the text is longer then the available width, it will be clipped. =item * B<-titlereverse> < BOOLEAN > The title can be drawn in normal or in reverse type. If -titlereverse is true, the text will be drawn in reverse type. The default is to use reverse type. =item * B<-titlefullwidth> < BOOLEAN > If -titlereverse is true, the title can be stretched to fill the complete width of the widget by giving -titlefullwidth a true value. By default this option is disabled. =back =head2 SCROLLBARS: Remark: Since the user of a Curses::UI program has no real control over the so called "scrollbars", they aren't really scrollbars. A better name would be something like "document location indicators". But since they look so much like scrollbars I decided I could get away with this naming convention. =over 4 =item * B<-vscrollbar> < VALUE > VALUE can be 'left', 'right', another true value or false. If -vscrollbar has a true value, a vertical scrollbar will be drawn by the widget. If this true value happens to be "left", the scrollbar will be drawn on the left side of the widget. In all other cases it will be drawn on the right side. The default is not to draw a vertical scrollbar. For widget programmers: To control the scrollbar, the widget data -vscrolllen (the total length of the content of the widget) and -vscrollpos (the current position in the document) should be set. If Curses::UI::Widget::draw is called, the scrollbar will be drawn. =item * B<-hscrollbar> < VALUE > VALUE can be 'top', 'bottom', another true value or false. If -hscrollbar has a true value, a horizontal scrollbar will be drawn by the widget. If this true value happens to be "top", the scrollbar will be drawn at the top of the widget. In all other cases it will be drawn at the bottom. The default is not to draw a horizontal scrollbar. For widget programmers: To control the scrollbar, the widget data -hscrolllen (the maximum width of the content of the widget) and -hscrollpos (the current horizontal position in the document) should be set. If Curses::UI::Widget::draw is called, the scrollbar will be drawn. =back =head2 EVENTS =over 4 =item * B<-onfocus> < CODEREF > This sets the onFocus event handler for the widget. If the widget gets the focus, the code in CODEREF will be executed. It will get the widget reference as its argument. =item * B<-onblur> < CODEREF > This sets the onBlur event handler for the widget. If the widget loses the focus, the code in CODEREF will be executed. It will get the widget reference as its argument. =back =head1 METHODS =over 4 =item * B ( OPTIONS ) Create a new Curses::UI::Widget instance using the options in HASH. =item * B ( ) Layout the widget. Compute the size the widget needs and see if it fits. Create the curses windows that are needed for the widget (the border and the effective drawing area). =item * B ( BOOLEAN ) Draw the Curses::UI::Widget. If BOOLEAN is true, the screen will not update after drawing. By default this argument is false, so the screen will update after drawing the widget. =item * B ( ) If the widget is visible (it is not hidden and it is in the window that is currently on top) and if intellidraw is not disabled for it (B<-intellidraw> has a true value) it is drawn and the curses routine doupdate() will be called to update the screen. This is useful if you change something in a widget and want it to update its state. If you simply call draw() and doupdate() yourself, then the widget will also be drawn if it is on a window that is currently not on top. This would result in the widget being drawn right through the contents of the window that is currently on top. =item * B ( ) Give focus to the widget. In Curses::UI::Widget, this method immediately returns, so the widget will not get focused. A derived class that needs focus, must override this method. =item * B ( [BOOLEAN] ) If BOOLEAN is set to a true value the widget will be focusable, false will make it unfocusable. If not argument is given, it will return the current state. =item * B ( ) This method makes the current widget lose it's focus. It returns the current widget. =item * B ( ) Gives the widget a modal focus, i.e. no other widget can be active till this widget is removed. =item * B ( TEXT ) Change the title that is shown in the border of the widget to TEXT. =item * B<width> ( ) =item * B<height> ( ) These methods return the total width and height of the widget. This is the space that the widget itself uses plus the space that is used by the outside padding. =item * B<borderwidth> ( ) =item * B<borderheight> ( ) These methods return the width and the height of the border of the widget. =item * B<canvaswidth> ( ) =item * B<canvasheight> ( ) These methods return the with and the height of the effective drawing area of the widget. This is the area where the draw() method of a widget may draw the contents of the widget (BTW: the curses window that is associated to this drawing area is $this->{-canvasscr}). =item * B<width_by_windowscrwidth> ( NEEDWIDTH, OPTIONS ) =item * B<height_by_windowscrheight> ( NEEDHEIGHT, OPTIONS ) These methods are exported by this module. These can be used in child classes to easily compute the total width/height the widget needs in relation to the needed width/height of the effective drawing area ($this->{-canvasscr}). The OPTIONS contains the options that will be used to create the widget. So if we want a widget that has a drawing area height of 1 and that has a border, the -height option can be computed using something like: my $height = height_by_windowscrheight(1, -border => 1); =item * B<generic_focus> ( BLOCKTIME, CTRLKEYS, CURSOR, PRECALLBACK ) For most widgets the B<generic_focus> method will be enough to handle focusing. This method will do the following: It starts a loop for reading keyboard input from the user. At the start of this loop the PRECALLBACK is called. This callback can for example be used for layouting the widget. Then, the widget is drawn. Now a key is read or if the DO_KEY:<key> construction was used, the <key> will be used as if it was read from the keyboard (you can find more on this construction below). If the DO_KEY:<key> construction was not used, a key is read using the B<get_key> method which is in L<Curses::UI::Common|Curses::UI::Common>. The arguments BLOCKTIME, CTRLKEYS and CURSOR are passed to B<get_key>. Now the key is checked. If the value of the key is -1, B<get_key> did not read a key at all. In that case, the program will go back to the start of the loop. As soon as a key is read, this key will be handed to the B<process_bindings> method (see below). The returnvalue of this method (called RETURN from now on) will be used to determine what to do next. We have the following cases: * B<RETURN matches DO_KEY:<key>> The <key> is extracted from RETURN. The loop is restarted and <key> will be used as if it was entered using the keyboard. * B<RETURN is a CODE reference> RETURN will be returned to the caller of B<generic_focus>. This will have the widget lose its focus. The caller then can execute the code. * B<RETURN is a SCALAR value> RETURN will be returned to the caller of B<generic_focus>. This will have the widget lose its focus. * B<anything else> The widget will keep its focus. The loop will be restarted all over again. So, if you are writing a binding routine for a widget, you can have the focus to stay at the widget by returning the widget instance itself. Example: sub myroutine() { my $this = shift; .... do your thing .... return $this; } =item * B<process_bindings> ( KEY ) KEY -> maps via binding to -> ROUTINE -> maps to -> VALUE This method will try to find out if there is a binding defined for the KEY. If no binding is found, the method will return the widget object itself. If a binding is found, the method will check if there is an corresponding ROUTINE. If the ROUTINE can be found it will check if it's VALUE is a code reference. If it is, the code will be executed and the returnvalue of this code will be returned. Else the VALUE will directly be returned. =item * B<clear_binding> ( ROUTINE ) Clear all keybindings for routine ROUTINE. =item * B<set_routine> ( ROUTINE, VALUE ) Set the routine ROUTINE to the VALUE. The VALUE may either be a scalar value or a code reference. If B<process_bindings> (see above) sees a scalar value, it will return this value. If it sees a coderef, it will execute the code and return the returnvalue of this code. =item * B<set_binding> ( ROUTINE, KEYLIST ) Bind the keys in the list KEYLIST to the ROUTINE. If you use an empty string for a key, then this routine will become the default routine (in case no other keybinding could be found). This is for example used in the TextEditor widget. =item * B<set_event> ( EVENT, [CODEREF] ) This routine will set the callback for event EVENT to CODEREF. If CODEREF is omitted or undefined, the event will be cleared. =item * B<clear_event> ( EVENT ) This will clear the callback for event EVENT. =item * B<run_event> ( EVENT ) This routine will check if a callback for the event EVENT is set and if is a code reference. If this is the case, it will run the code and return its return value. =item * B<onFocus> ( CODEREF ) This method can be used to set the B<-onfocus> event handler (see above) after initialization of the widget. =item * B<onBlur> ( CODEREF ) This method can be used to set the B<-onblur> event handler (see above) after initialization of the widget. =item * B<parentwindow> ( ) Returns this parent window for the widget or undef if no parent window can be found (this should not happen). =item * B<in_topwindow> ( ) Returns true if the widget is in the window that is currently on top. =item * B<userdata> ( [ SCALAR ] ) This method will return the user internal data stored in this widget. If a SCALAR parameter is specified it will also set the current user data to it. =item * B<beep_on> ( ) This sets the data member $this->{B<-nobeep>} of the class instance to a false value. =item * B<beep_off> ( ) This sets the data member $this->{B<-nobeep>} of the class instance to a true value. =item * B<dobeep> ( ) This will call the curses beep() routine, but only if B<-nobeep> is false. =back =head1 WIDGET STRUCTURE Here's a basic framework for creating a new widget. You do not have to follow this framework. As long as your widget has the methods new(), layout(), draw() and focus(), it can be used in Curses::UI. package Curses::UI::YourWidget use Curses; use Curses::UI::Widget; use Curses::UI::Common; # some common widget routines use vars qw($VERSION @ISA); $VERSION = '0.01'; @ISA = qw(Curses::UI::Widget Curses::UI::Common); # For a widget that can get focus, you should define # the routines that are used to control the widget. # Each routine has a name. This name is used in # the definition of the bindings. # The value can be a string or a subroutine reference. # A string will make the widget return from focus. # my %routines = ( 'return' => 'LOSE_FOCUS', 'key-a' => \&key_a, 'key-other' => \&other_key ); # Using the bindings, the routines can be binded to key- # presses. If the keypress is an empty string, this means # that this is the default binding. If the key is not # handled by any other binding, it's handled by this # default binding. # my %bindings = ( KEY_DOWN() => 'return', # down arrow will make the # widget lose it's focus 'a' => 'key-a', # a-key will trigger key_a() '' => 'key-other' # any other key will trigger other_key() ); # The creation of the widget. When doing it this way, # it's easy to make optional and forced arguments # possible. A forced argument could for example be # -border => 1, which would mean that the widget # always has a border, which can't be disabled by the # programmer. The arguments can of course be used # for storing the current state of the widget. # sub new () { my $class = shift; my %args = ( -optional_argument_1 => "default value 1", -optional_argument_2 => "default value 2", ....etc.... @_, -forced_argument_1 => "forced value 1", -forced_argument_2 => "forced value 2", ....etc.... -bindings => {%bindings}, -routines => {%routines}, ); # Create the widget and do the layout of it. my $this = $class->SUPER::new( %args ); $this->layout; return $this; } # Each widget should have a layout() routine. Here, # the widget itself and it's contents can be layouted. # In case of a very simple widget, this will only mean # that the Widget has to be layouted (in which case the # routine could be left out, since it's in the base # class already). In other cases you will have to add # your own layout code. This routine is very important, # since it will enable the resizeability of the widget! # sub layout () { my $this = shift; $this->SUPER::layout; return $this if $Curses::UI::screen_too_small; ....your own layout stuff.... # If you decide that the widget does not fit on the # screen, then set $Curses::UI::screen_too_small # to a true value and return. if ( ....the widget does not fit.... ) { $Curses::UI::screen_too_small++; return $this; } return $this; } # The widget is drawn by the draw() routine. The # $no_update part is used to disable screen flickering # if a lot of widgets have to be drawn at once (for # example on resizing or redrawing). The curses window # which you can use for drawing the widget's contents # is $this->{-canvasscr}. # sub draw(;$) { my $this = shift; my $no_doupdate = shift || 0; return $this if $this->hidden; $this->SUPER::draw(1); ....your own draw stuff.... $this->{-canvasscr}->addstr(0, 0, "Fixed string"); ....your own draw stuff.... $this->{-canvasscr}->noutrefresh; doupdate() unless $no_doupdate; return $this; } # Focus the widget. If you do not override this routine # from Curses::UI::Widget, the widget will not be # focusable. Mostly you will use the generic_focus() method. # sub focus() { my $this = shift; $this->show; # makes the widget visible if it was invisible return $this->generic_focus( undef, # delaytime, default = 2 (1/10 second). NO_CONTROLKEYS, # disable controlkeys like CTRL+C. To enable # them use CONTROLKEYS instead. CURSOR_INVISIBLE, # do not show the cursor (if supported). To # show the cursor use CURSOR_VISIBLE. \&pre_key_routine, # optional callback routine to execute # before a key is read. Mostly unused. ); } ....your own widget handling routines.... =head1 SEE ALSO L<Curses::UI|Curses::UI> =head1 AUTHOR Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/lib/Curses/UI.pm�������������������������������������������������������������������0000644�0001750�0000144�00000105312�11630213652�015146� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package Curses::UI; use base qw(Curses::UI::Common Curses::UI::Container); # If we do not know a terminal type, then imply VT100. BEGIN { $ENV{TERM} = 'vt100' unless defined $ENV{TERM} } use strict; use warnings; use Curses; use Curses::UI::Language; use Curses::UI::Color; use FileHandle; use Term::ReadKey; =head1 NAME Curses::UI - A curses based OO user interface framework =head1 VERSION Version 0.9609 =cut use vars qw( $VERSION ); $VERSION = 0.9609; =head1 SYNOPSIS use Curses::UI; # create a new C::UI object my $cui = Curses::UI->new( -clear_on_exit => 1, -debug => $debug, ); # this is where we gloss over setting up all the widgets and data # structures :) # start the event loop $cui->mainloop; =head1 DESCRIPTION Curses::UI is an object-oriented user interface framework for Perl. It contains basic widgets (like buttons and text areas), more "advanced" widgets (like UI tabs and a fully-functional basic text editor), and some higher-level classes like pre-fab error dialogues. See L<Curses::UI::Tutorial> and the C<examples> directory of the source distribution for more introductory material. =cut $Curses::UI::debug = 0; $Curses::UI::screen_too_small = 0; $Curses::UI::initialized = 0; $Curses::UI::color_support = 0; $Curses::UI::color_object = 0; $Curses::UI::ncurses_mouse = 0; $Curses::UI::gpm_mouse = 0; # Detect if we should use the new moushandler if ($ENV{"TERM"} ne "xterm") { eval { require Curses::UI::Mousehandler::GPM; import Curses::UI::Mousehandler::GPM; }; if (!$@) { $Curses::UI::gpm_mouse = gpm_enable(); print STDERR "DEBUG: gpm_mouse: " . $Curses::UI::gpm_mouse . "\n" if $Curses::UI::debug; } } else { # Detect ncurses functionality. Magic for Solaris 8 eval { $Curses::UI::ncurses_mouse = (Curses->can('NCURSES_MOUSE_VERSION') && (NCURSES_MOUSE_VERSION() >= 1 ) ) }; print STDERR "DEBUG: Detected mouse support $Curses::UI::ncurses_mouse\n" if $Curses::UI::debug; } =head1 CONSTRUCTOR Create a new Curses::UI object: my $cui = Curses::UI->new( OPTIONS ); where C<OPTIONS> is one or more of the following. =head2 -clear_on_exit If true, Curses::UI will call C<clear> on exit. Defaults to false. =head2 -color_support If true, Curses::UI tries to enable color for the application. Defaults to false. =head2 -compat If true, Curses::UI will run in compatibility mode, meaning that only very simple characters will be used for creating the widgets. Defaults to false. =head2 -keydelay If set to a positive integer, Curses::UI will track elapsed seconds since the user's last keystroke, preventing timer events from occurring for the specified number of seconds afterwards. By default this option is set to '0' (disabled). =head2 -mouse_support Curses::UI attempts to auto-discover if mouse support should be enabled or not. This option allows a hard override. Expects a boolean value. =head2 -userdata Takes a scalar (frequently a hashref) as its argument, and stows that scalar inside the Curses::UI object where it can be retrieved with the L<#userdata> method. Handy inside callbacks and the like. =head2 -default_colors Directs the underlying Curses library to allow use of default color pairs on terminals. Is preset to true and you almost certainly don't want to twiddle it. See C<man use_default_colors> if you think you do. =cut sub new { my ($class,%userargs) = @_; fatalerror("Curses::UI->new can only be called once!") if $Curses::UI::initialized; &Curses::UI::Common::keys_to_lowercase(\%userargs); my %args = ( -compat => 0, # Use compatibility mode? -clear_on_exit => 0, # Clear screen if program exits? -cursor_mode => 0, # What is the current cursor_mode? -debug => undef, # Turn on debugging mode? -keydelay => 0, # Track seconds since last keystroke? -language => undef, # Which language to use? -mouse_support => 1, # Do we want mouse support -overlapping => 1, # Whether overlapping widgets are supported -color_support => 0, -default_colors=> 1, #user data -userdata => undef, #user internal data %userargs, -read_timeout => -1, # full blocking read by default -scheduled_code => [], -added_code => {}, -lastkey => 0, # Last keypress time (set in mainloop) ); $Curses::UI::debug = $args{-debug} if defined $args{-debug}; $Curses::UI::ncurses_mouse = $args{-mouse_support} if defined $args{-mouse_support}; if ($Curses::UI::gpm_mouse && $args{-mouse_support}) { $Curses::UI::ncurses_mouse = 1; $args{-read_timeout} = 0.25; } else { $Curses::UI::gpm_mouse = 0; } my $self = bless { %args }, $class; my $lang = new Curses::UI::Language($self->{-language}); $self->lang($lang); print STDERR "DEBUG: Loaded language: $lang->{-lang}\n" if $Curses::UI::debug; # Color support $Curses::UI::color_support = $args{-color_support} if defined $args{-color_support}; $self->layout(); return $self; } DESTROY { my $self = shift; my $scr = $self->{-canvasscr}; $scr->delwin() if (defined($scr)); endwin(); $Curses::UI::initialized = 0; if ($self->{-clear_on_exit}) { Curses::erase(); Curses::clear() } } =head1 EVENT HANDLING METHODS =head2 mainloop The Curses::UI event handling loop. Call once setup is finished to "start" a C::UI program. =cut sub mainloop { my ($self) = @_; # Draw the initial screen. $self->focus(undef, 1); # 1 = forced focus $self->draw; doupdate(); $self->{mainloop}=1; # Inifinite event loop. while ($self->{mainloop}) { $self->do_one_event } } =head2 mainloopExit This exits the main loop. =cut sub mainloopExit{ my $self=$_[0]; $self->{mainloop}=undef; } =head2 schedule_event Pushes its argument (a coderef) onto the scheduled event stack =cut sub schedule_event { my ($self, $code) = @_; $self->fatalerror("schedule_event(): callback is no CODE reference") unless defined $code and ref $code eq 'CODE'; push @{$self->{-scheduled_code}}, $code; } =head1 WINDOW/LAYOUT METHODS =head2 layout The layout method of Curses::UI tries to find the size of the screen then calls the C<layout> method of every contained object (i.e. window or widget). It is not normally necessary to call this method directly. =cut sub layout { my ($self) = @_; $Curses::UI::screen_too_small = 0; # find the terminal size. my ($cols,$lines) = GetTerminalSize; $ENV{COLS} = $cols; $ENV{LINES} = $lines; if ($Curses::UI::initialized) { my $scr = $self->{-canvasscr}; $scr->delwin() if (defined($scr)); endwin(); } # Initialize the curses screen. initscr(); noecho(); raw(); # Colors if ($Curses::UI::color_support) { if ( has_colors() ) { $Curses::UI::color_object = new Curses::UI::Color(-default_colors => $self->{-default_colors}); } else { $Curses::UI::color_support = 0; } } # Mouse events if possible my $old = 0; my $mmreturn; if ( $Curses::UI::ncurses_mouse ) { print STDERR "DEBUG: ncurses mouse events are enabled\n" if $Curses::UI::debug; # In case of gpm, mousemask fails. (MT: Not for me, maybe GPM changed?) eval { $mmreturn = mousemask( ALL_MOUSE_EVENTS(), $old ) }; if ($Curses::UI::debug) { print STDERR "DEBUG: mousemask returned $mmreturn\n"; print STDERR "DEBUG: Old is now $old\n"; print STDERR "DEBUG: mousemask() failed: $@\n" if $@; } } # Create root window. my $root = newwin($lines, $cols, 0, 0); die "newwin($lines, $cols, 0, 0) failed\n" unless defined $root; # Let this object present itself as a standard # Curses::UI widget, regarding size, location and # drawing area. This will make it possible for # child windows / widgets to layout and draw themselves. $self->{-width} = $self->{-w} = $self->{-bw} = $cols; $self->{-height} = $self->{-h} = $self->{-bh} = $lines; $self->{-x} = $self->{-y} = 0; $self->{-canvasscr} = $root; # Walk through all contained objects and let them # layout themselves. $self->layout_contained_objects; $self->draw(); $Curses::UI::initialized = 1; return $self; } sub layout_new() { my $self = shift; $Curses::UI::screen_too_small = 0; # find the terminal size. my ($cols,$lines) = GetTerminalSize; $ENV{COLS} = $cols; $ENV{LINES} = $lines; # Let this object present itself as a standard # Curses::UI widget, regarding size, location and # drawing area. This will make it possible for # child windows / widgets to layout and draw themselves. # $self->{-width} = $self->{-w} = $self->{-bw} = $cols; $self->{-height} = $self->{-h} = $self->{-bh} = $lines; $self->{-x} = $self->{-y} = 0; # $self->{-canvasscr} = $root; # Walk through all contained objects and let them # layout themselves. $self->layout_contained_objects; $Curses::UI::initialized = 1; $self->draw(); return $self; } # ---------------------------------------------------------------------- # Event handling # ---------------------------------------------------------------------- # TODO: document sub do_one_event(;$) { my $self = shift; my $object = shift; $object = $self unless defined $object; eval {curs_set($self->{-cursor_mode})}; # gpm mouse? if ($Curses::UI::gpm_mouse) { $self->handle_gpm_mouse_event($object); doupdate(); } # Read a key or use the feeded key. my $key = $self->{-feedkey}; unless (defined $key) { $key = $self->get_key($self->{-read_timeout}); } $self->{-feedkey} = undef; # If there was a keypress, set -lastkey $self->{-lastkey} = time() unless ($key eq '-1'); # ncurses sends KEY_RESIZE() key on resize. Ignore this key. # TODO: Try to redraw and layout everything anew # KEY_RESIZE doesn't seem to work right; if (Curses->can("KEY_RESIZE")) { eval { $key = '-1' if $key eq KEY_RESIZE(); }; } my ($cols,$lines) = GetTerminalSize; if ( ($ENV{COLS} != $cols) || ( $ENV{LINES} != $lines )) { $self->layout(); $self->draw; } # ncurses sends KEY_MOUSE() if ($Curses::UI::ncurses_mouse) { if ($key eq KEY_MOUSE()) { print STDERR "DEBUG: Got a KEY_MOUSE(), handeling it\n" if $Curses::UI::debug; $self->handle_mouse_event($object); doupdate(); return $self; } } # If the screen is too small, then <CTRL+C> will exit. # Else the next event loop will be started. if ($Curses::UI::screen_too_small) { exit(1) if $key eq "\cC"; return $self; } # Delegate the keypress. This is not done to $self, # but to $object, so all events will go to the # object that called do_one_event(). This is used to # enable modal focusing. $object->event_keypress($key) unless $key eq '-1'; # Execute timer code $self->do_timer; # Execute one scheduled event; if (@{$self->{-scheduled_code}}) { my $code = shift @{$self->{-scheduled_code}}; $code->($self); } # Execute added code foreach my $key (keys %{$self->{-added_code}}) { my $code = $self->{-added_code}->{$key}; $self->fatalerror("Method $key is not a coderef") if (ref $code ne 'CODE'); $code->($self); } # Update the screen. doupdate(); return $self; } # TODO: document # TODO: document sub add_callback() { my $self = shift; my $id = shift; my $code = shift; $self->fatalerror( "add_callback(): is is not set" ) unless defined $id; $self->fatalerror( "add_callback(): callback is no CODE reference" ) unless defined $code and ref $code eq 'CODE'; $self->{-added_code}->{$id} = $code; } # TODO: document sub delete_callback() { my $self = shift; my $id = shift; $self->fatalerror( "delete_callback(): id is not set" ) unless defined $id; delete $self->{-added_code}->{$id} if defined $self->{-added_code}->{$id}; } sub draw() { my $self = shift; my $no_doupdate = shift || 0; if ($Curses::UI::screen_too_small) { my $s = $self->{-canvasscr}; $s->clear; $s->addstr(0, 0, $self->lang->get('screen_too_small')); $s->move(4,0); $s->noutrefresh(); doupdate(); } else { $self->SUPER::draw(1); doupdate() unless $no_doupdate; } } # TODO: document sub feedkey() { my $self = shift; my $key = shift; $self->{-feedkey} = $key; return $self; } # TODO: document sub flushkeys() { my $self = shift; my $key = ''; my @k = (); until ( $key eq "-1" ) { $key = $self->get_key(0); } } # Returns 0 if less than -keydelay seconds have elapsed since the last # user action. Returns the number of elapsed seconds otherwise. sub keydelay() { my $self = shift; my $time = time(); my $elapsed = $time - $self->{-lastkey}; return 0 if ($elapsed < $self->{-keydelay}); return $elapsed; } # ---------------------------------------------------------------------- # Timed event handling # ---------------------------------------------------------------------- sub set_read_timeout() { my $self = shift; my $new_timeout = -1; TIMER: while (my ($id, $config) = each %{$self->{-timers}}) { # Skip timer if it is disabled. next TIMER unless $config->{-enabled}; $new_timeout = $config->{-time} unless $new_timeout != -1 and $new_timeout < $config->{-time}; } $new_timeout = 1 if $new_timeout < 0 and $new_timeout != -1; $self->{-read_timeout} = $new_timeout; return $self; } sub set_timer($$;) { my $self = shift; my $id = shift; my $callback = shift; my $time = shift || 1; $self->fatalerror( "add_timer(): callback is no CODE reference" ) unless defined $callback and ref $callback eq 'CODE'; $self->fatalerror( "add_timer(): id is not set" ) unless defined $id; my $config = { -time => $time, -callback => $callback, -enabled => 1, -lastrun => time(), }; $self->{-timers}->{$id} = $config; $self->set_read_timeout; return $self; } sub disable_timer($;) { my ($self,$id) = @_; if (defined $self->{-timers}->{$id}) { $self->{-timers}->{$id}->{-enabled} = 0; } $self->set_read_timeout; return $self; } sub enable_timer($;) { my ($self,$id) = @_; if (defined $self->{-timers}->{$id}) { $self->{-timers}->{$id}->{-enabled} = 1; } $self->set_read_timeout; return $self; } sub delete_timer($;) { my ($self,$id) = @_; if (defined $self->{-timers}->{$id}) { delete $self->{-timers}->{$id}; } $self->set_read_timeout; return $self; } sub do_timer() { my $self = shift; my $now = time(); my $timers_done = 0; # Short-circuit timers if the keydelay hasn't elapsed if ($self->{-keydelay}) { return $self unless $self->keydelay; } TIMER: while (my ($id, $config) = each %{$self->{-timers}}) { # Skip timer if it is disabled. next TIMER unless $config->{-enabled}; # No -lastrun set? Then do it now. unless (defined $config->{-lastrun}) { $config->{-lastrun} = $now; next TIMER; } if ($config->{-lastrun} <= ($now - $config->{-time})) { $config->{-callback}->($self); $config->{-lastrun} = $now; $timers_done++; } } # Bring the cursor back to the focused object by # redrawing it. Due to drawing other objects, it might # have moved to another widget or screen location. # $self->focus_path(-1)->draw if $timers_done; return $self; } # ---------------------------------------------------------------------- # Mouse events # ---------------------------------------------------------------------- sub handle_mouse_event() { my $self = shift; my $object = shift; $object = $self unless defined $object; my $MEVENT = 0; getmouse($MEVENT); # $MEVENT is a struct. From curses.h (note: this might change!): # # typedef struct # { # short id; /* ID to distinguish multiple devices */ # int x, y, z; /* event coordinates (character-cell) */ # mmask_t bstate; /* button state bits */ # } MEVENT; # # --------------- # s signed short # x null byte # x null byte # --------------- # i integer # --------------- # i integer # --------------- # i integer # --------------- # l long # --------------- my ($id, $x, $y, $z, $bstate) = unpack("sx2i3l", $MEVENT); my %MEVENT = ( -id => $id, -x => $x, -y => $y, -bstate => $bstate, ); # Get the objects at the mouse event position. my $tree = $self->object_at_xy($object, $MEVENT{-x}, $MEVENT{-y}); # Walk through the object tree, top object first. foreach my $object (reverse @$tree) { # Send the mouse-event to the object. # Leave the loop if the object handled the event. print STDERR "Asking $object to handle $MEVENT{-bstate} ...\n" if $Curses::UI::debug; my $return = $object->event_mouse(\%MEVENT); last if defined $return and $return ne 'DELEGATE'; } } sub handle_gpm_mouse_event() { my $self = shift; my $object = shift; $object = $self unless defined $object; return unless $Curses::UI::gpm_mouse; my $MEVENT = gpm_get_mouse_event(); # $MEVENT from C:UI:MH:GPM is identical. return unless $MEVENT; my ($id, $x, $y, $z, $bstate) = unpack("sx2i3l", $MEVENT); my %MEVENT = ( -id => $id, -x => $x, -y => $y, -bstate => $bstate, ); # Get the objects at the mouse event position. my $tree = $self->object_at_xy($object, $MEVENT{-x}, $MEVENT{-y}); # Walk through the object tree, top object first. foreach my $object (reverse @$tree) { # Send the mouse-event to the object. # Leave the loop if the object handled the event. my $return = $object->event_mouse(\%MEVENT); last if defined $return and $return ne 'DELEGATE'; } } sub object_at_xy($$;$) { my $self = shift; my $object = shift; my $x = shift; my $y = shift; my $tree = shift; $tree = [] unless defined $tree; push @$tree, $object; my $idx = -1; while (defined $object->{-draworder}->[$idx]) { my $testobj = $object->getobj($object->{-draworder}->[$idx]); $idx--; # Find the window parameters for the $testobj. my $scr = defined $testobj->{-borderscr} ? '-borderscr' : '-canvasscr'; my $winp = $testobj->windowparameters($scr); # Does the click fall inside this object? if ( $x >= $winp->{-x} and $x < ($winp->{-x}+$winp->{-w}) and $y >= $winp->{-y} and $y < ($winp->{-y}+$winp->{-h}) ) { if ( $testobj->isa('Curses::UI::Container') and not $testobj->isa('Curses::UI::ContainerWidget')) { $self->object_at_xy($testobj, $x, $y, $tree) } else { push @$tree, $testobj; } return $tree; } } return $tree; } # ---------------------------------------------------------------------- # Other subroutines # ---------------------------------------------------------------------- # TODO: document sub fatalerror($$;$) { my $self = shift; my $error = shift; my $exit = shift; $exit = 1 unless defined $exit; chomp $error; $error .= "\n"; my $s = $self->{-canvasscr}; $s->clear; $s->addstr(0,0,"Fatal program error:\n" . "-"x($ENV{COLS}-1) . "\n" . $error . "-"x($ENV{COLS}-1) . "\n" . "Press any key to exit..."); $s->noutrefresh(); doupdate(); $self->flushkeys(); for (;;) { my $key = $self->get_key(); last if $key ne "-1"; } exit($exit); } sub usemodule($;) { my $self = shift; my $class = shift; # Create class filename. my $file = $class; $file =~ s|::|/|g; $file .= '.pm'; # Automatically load the required class. if (not defined $INC{$file}) { eval { require $file; $class->import; }; # Fatal error if the class could not be loaded. $self->fatalerror("Could not load $class from $file:\n$@") if $@; } return $self; } sub focus_path() { my $self = shift; my $index = shift; my $p_obj = $self; my @path = ($p_obj); for(;;) { my $p_el = $p_obj->{-draworder}->[-1]; last unless defined $p_el; $p_obj = $p_obj->{-id2object}->{$p_el}; push @path, $p_obj; last if $p_obj->isa('Curses::UI::ContainerWidget'); } return (defined $index ? $path[$index] : @path); } # add() is overridden, because we only want to be able # to add Curses::UI:Window objects to the Curses::UI # rootlevel. # sub add() { my $self = shift; my $id = shift; my $class = shift; my %args = @_; # Make it possible to specify WidgetType instead of # Curses::UI::WidgetType. $class = "Curses::UI::$class" if $class !~ /\:\:/ or $class =~ /^Dialog\:\:[^\:]+$/; $self->usemodule($class); $self->fatalerror( "You may only add Curses::UI::Window objects to " . "Curses::UI and no $class objects" ) unless $class->isa('Curses::UI::Window'); $self->SUPER::add($id, $class, %args); } # Sets/Get the user data sub userdata { my $self = shift; if (defined $_[0]) { $self->{-userdata} = $_[0]; } return $self->{-userdata}; } # ---------------------------------------------------------------------- # Focusable dialog windows # ---------------------------------------------------------------------- sub tempdialog() { my $self = shift; my $class = shift; my %args = @_; my $id = "__window_$class"; my $dialog = $self->add($id, $class, %args); $dialog->modalfocus; my $return = $dialog->get; $self->delete($id); $self->root->focus(undef, 1); return $return; } # The argument list will be returned unchanged, unless it # contains only one item. In that case ($ifone, $_[0]) will # be returned. This enables constructions like: # # $cui->dialog("Some dialog message"); # # instead of: # # $cui->dialog(-message => "Some dialog message"); # sub process_args() { my $self = shift; my $ifone = shift; if (@_ == 1) { @_ = ($ifone => $_[0]) } return @_; } sub error() { my $self = shift; my %args = $self->process_args('-message', @_); $self->tempdialog('Dialog::Error', %args); } sub dialog() { my $self = shift; my %args = $self->process_args('-message', @_); $self->tempdialog('Dialog::Basic', %args); } sub question() { my $self = shift; my %args = $self->process_args('-question', @_); $self->tempdialog('Dialog::Question', %args); } sub calendardialog() { my $self = shift; my %args = $self->process_args('-title', @_); $self->tempdialog('Dialog::Calendar', %args); } sub filebrowser() { my $self = shift; my %args = $self->process_args('-title', @_); # Create title unless (defined $args{-title}) { my $l = $self->root->lang; $args{-title} = $l->get('file_title'); } # Select a file to load from. $self->tempdialog('Dialog::Filebrowser', %args); } sub dirbrowser() { my $self = shift; my %args = $self->process_args('-title', @_); # Create title unless (defined $args{-title}) { my $l = $self->root->lang; $args{-title} = $l->get('dir_title'); } # Select a file to load from. $self->tempdialog('Dialog::Dirbrowser', %args); } sub savefilebrowser() { my $self = shift; my %args = $self->process_args('-title', @_); my $l = $self->root->lang; # Create title. $args{-title} = $l->get('file_savetitle') unless defined $args{-title}; # Select a file to save to. my $file = $self->filebrowser(-editfilename => 1, %args); return unless defined $file; # Check if the file exists. Ask for overwrite # permission if it does. if (-e $file) { # Get language specific data. my $pre = $l->get('file_overwrite_question_pre'); my $post = $l->get('file_overwrite_question_post'); my $title = $l->get('file_overwrite_title'); my $overwrite = $self->dialog( -title => $title, -buttons => [ 'yes', 'no' ], -message => $pre . $file . $post, ); return unless $overwrite; } return $file; } sub loadfilebrowser() { my $self = shift; my %args = $self->process_args('-title', @_); # Create title unless (defined $args{-title}) { my $l = $self->root->lang; $args{-title} = $l->get('file_loadtitle'); } $self->filebrowser(-editfilename => 0, %args); } # ---------------------------------------------------------------------- # Non-focusable dialogs # ---------------------------------------------------------------------- my $status_id = "__status_dialog"; sub status($;) { my $self = shift; my %args = $self->process_args('-message', @_); $self->delete($status_id); $self->add($status_id, 'Dialog::Status', %args)->draw; return $self; } sub nostatus() { my $self = shift; $self->delete($status_id); $self->flushkeys(); $self->draw; return $self; } sub progress() { my $self = shift; my %args = @_; $self->add( "__progress_$self", 'Dialog::Progress', %args ); $self->draw; return $self; } sub setprogress($;$) { my $self = shift; my $pos = shift; my $message = shift; # If I do not do this, the progress bar seems frozen # if a key is pressed on my Solaris machine. Flushing # the input keys solves this. And this is not a bad # thing to do during a progress dialog (input is ignored # this way). $self->flushkeys; my $p = $self->getobj("__progress_$self"); return unless defined $p; $p->pos($pos) if defined $pos; $p->message($message) if defined $message; $p->draw; return $self; } sub noprogress() { my $self = shift; $self->delete("__progress_$self"); $self->flushkeys; $self->draw; return $self; } sub leave_curses() { my $self = shift; def_prog_mode(); endwin(); } sub reset_curses() { my $self = shift; reset_prog_mode(); $self->layout(); # In case the terminal has been resized } ### Color support sub color() { my $self = shift; return $Curses::UI::color_object; } sub set_color { my $self = shift; my $co = shift; $Curses::UI::color_object = $co; } # ---------------------------------------------------------------------- # Accessor functions # ---------------------------------------------------------------------- sub compat(;$) { shift()->accessor('-compat', shift()) } sub clear_on_exit(;$) { shift()->accessor('-clear_on_exit', shift()) } sub cursor_mode(;$) { shift()->accessor('-cursor_mode', shift()) } sub lang(;$) { shift()->accessor('-language_object', shift()) } sub overlapping(;$) { shift()->accessor('-overlapping', shift()) } # TODO: document sub debug(;$) { my $self = shift; my $value = shift; $Curses::UI::debug = $self->accessor('-debug', $value); } =head1 CONVENIENCE DIALOG METHODS =head2 dialog Use the C<dialog> method to show a dialog window. If you only provide a single argument, this argument will be used as the message to show. Example: $cui->dialog("Hello, world!"); If you want to have some more control over the dialog window, you will have to provide more arguments (for an explanation of the arguments that can be used, see L<Curses::UI::Dialog::Basic>. Example: my $yes = $cui->dialog( -message => "Hello, world?", -buttons =3D> ['yes','no'], -values => [1,0], -title => 'Question', ); if ($yes) { # whatever } =head2 error The C<error> method will create an error dialog. This is basically a Curses::UI::Dialog::Basic, but it has an ASCII-art exclamation sign drawn left to the message. For the rest it's just like C<dialog>. Example: $cui->error("It's the end of the\n" ."world as we know it!"); =head2 filebrowser Creates a file browser dialog. For an explanation of the arguments that can be used, see L<Curses::UI::Dialog::Filebrowser>. Example: my $file = $cui->filebrowser( -path => "/tmp", -show_hidden => 1, ); # Filebrowser will return undef # if no file was selected. if (defined $file) { unless (open F, ">$file") { print F "Hello, world!\n"; close F; } else { $cui->error(qq(Error on writing to "$file":\n$!)); } =head2 loadfilebrowser, savefilebrowser These two methods will create file browser dialogs as well. The difference is that these will have the dialogs set up correctly for loading and saving files. Moreover, the save dialog will check if the selected file exists or not. If it does exist, it will show an overwrite confirmation to check if the user really wants to overwrite the selected file. =head2 status, nostatus Using these methods it's easy to provide status information for the user of your program. The status dialog is a dialog with only a label on it. The status dialog doesn't really get the focus. It's only used to display some information. If you need more than one status, you can call C<status> subsequently. Any existing status dialog will be cleaned up and a new one will be created. If you are finished, you can delete the status dialog by calling the C<nostatus> method. Example: $cui->status("Saying hello to the world..."); # code for saying "Hello, world!" $cui->status("Saying goodbye to the world..."); # code for saying "Goodbye, world!" $cui->nostatus; =head2 progress, setprogress, noprogress Using these methods it's easy to provide progress information to the user. The progress dialog is a dialog with an optional label on it and a progress bar. Similar to the status dialog, this dialog does not get the focus. Using the C<progress> method, a new progress dialog can be created. This method takes the same arguments as the L<Curses::IU::Dialog::Progress> class. After that the progress can be set using C<setprogress>. This method takes one or two arguments. The first argument is the current position of the progressbar. The second argument is the message to show in the label. If one of these arguments is undefined, the current value will be kept. If you are finished, you can delete the progress dialog by calling the C<noprogress> method. $cui->progress( -max => 10, -message => "Counting 10 seconds...", ); for my $second (0..10) { $cui->setprogress($second) sleep 1; } $cui->noprogress; =cut =head1 OTHER METHODS =over 4 =item B<leave_curses> ( ) Temporarily leaves curses mode and recovers normal terminal mode. =item B<reset_curses> ( ) Return to curses mode after B<leave_curses()>. =item B<add> ( ID, CLASS, OPTIONS ) The B<add> method of Curses::UI is almost the same as the B<add> method of Curses::UI::Container. The difference is that Curses::UI will only accept classes that are (descendants) of the Curses::UI::Window class. For the rest of the information see L<Curses::UI::Container|Curses::UI::Container>. =item B<add_callback> ( ID, CODE) This method lets you add a callback into the mainloop permanently. The code is executed after the input handler has run. =item B<delete_callback> ( ID ) This method deletes the CODE specified by ID from the mainloop. =item B<usemodule> ( CLASSNAME ) Loads the with CLASSNAME given module. =item B<userdata> ( [ SCALAR ] ) This method will return the user internal data stored in the UI object. If a SCALAR parameter is specified it will also set the current user data to it. =item B<keydelay> ( ) This method is used internally to control timer events when the B<-keydelay> option is set, but it can be called directly it to find out if the required amount of time has passed since the user's last action. B<keydelay>() will return 0 if insufficent time has passed, and will return the number of elapsed seconds otherwise. =item B<compat> ( [BOOLEAN] ) The B<-compat> option will be set to the BOOLEAN value, unless BOOLEAN is omitted. The method returns the current value for B<-compat>. =item B<clear_on_exit> ( [BOOLEAN] ) The B<-clear_on_exit> option will be set to the BOOLEAN value, unless BOOLEAN is omitted. The method returns the current value for B<-clear_on_exit>. =item B<color> ( ) Returns the currently used Curses::UI::Color object =item B<set_color> ( OBJECT ) Replaces the currently used Color object with another. This can be used to fast change all colors in a Curses::UI application. =back =head1 SEE ALSO =over =item L<Curses> =item L<Curses::UI::POE> (a POE eventsystem and mainloop for Curses::UI) =item L<http://curses-ui.googlecode.com/> (SVN repo, info, and links) =back =head1 BUGS Please report any bugs or feature requests to C<bug-curses-ui@rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Curses-UI>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 AUTHOR Shawn Boyette C<< <mdxi@cpan.org> >> See the CREDITS file for additional information. =head1 COPYRIGHT & LICENSE Copyright 2001-2002 Maurice Makaay; 2003-2006 Marcus Thiesen; 2007, 2008 Shawn Boyette. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified under the same terms as perl itself. =cut =head1 CLASS LISTING =head2 Widgets =over =item L<Curses::UI::Buttonbox> =item L<Curses::UI::Calendar> =item L<Curses::UI::Checkbox> =item L<Curses::UI::Label> =item L<Curses::UI::Listbox> =item L<Curses::UI::Menubar> =item L<Curses::UI::MenuListbox> (used by Curses::UI::Menubar) =item L<Curses::UI::Notebook> =item L<Curses::UI::PasswordEntry> =item L<Curses::UI::Popupmenu> =item L<Curses::UI::Progressbar> =item L<Curses::UI::Radiobuttonbox> =item L<Curses::UI::SearchEntry> (used by Curses::UI::Searchable) =item L<Curses::UI::TextEditor> =item L<Curses::UI::TextEntry> =item L<Curses::UI::TextViewer> =item L<Curses::UI::Window> =back =head2 Dialogs =over =item L<Curses::UI::Dialog::Basic> =item L<Curses::UI::Dialog::Error> =item L<Curses::UI::Dialog::Filebrowser> =item L<Curses::UI::Dialog::Status> =back =head2 Base and Support Classes =over =item L<Curses::UI::Widget> =item L<Curses::UI::Container> =item L<Curses::UI::Color> =item L<Curses::UI::Common> =item L<Curses::UI::Searchable> =back =cut 1; # end of Curses::UI ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/Changes����������������������������������������������������������������������������0000644�0001750�0000144�00000073441�11630213716�013564� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Changelog for the Curses::UI distribution: Version 0.9609 ============== - Bugfix for crashing error in 0.9608 Version 0.9608 ============== - TextEditor doc patch from Zane C.B. - Patch to allow mainloop to halt from Zane C.B. - key handling fix from Scott McCoy - Background color set patch from Miquel van Smoorenburg - AIX fix from Shava Smallen - Fix for prototypes warnings from Damyan Ivanov Version 0.9607 ============== - Curses::UI::set_timer no longer calls int() on passed time value, allowing Time::HiRes support, thanks to Gilmar Santos, Jr. (RT#29026) - Fixed ancient bug in Popupmenu.pm, thanks to Davide Chiarini and Michael Arlt (RT#38211,25885) - POD testing bug introduced in last version now fixed Version 0.9606 ============== - Patch to Notebook.pm from Dominque Dumont (RT#39915) - Test::POD no longer required for install Version 0.9605 ============== - MANIFEST in 0.9604 was bad, causing pertesters FAIL Version 0.9604 ============== - MainLoop removal broke several examples. Fixed (thanks to Antony Gelberg) - Japanese localization added (thanks Takatoshi Kitano) Version 0.9603 ============== - MainLoop has been removed (please use '$cui->mainloop') - So the circular reference of $Curses::UI::rootobject has been removed as well - RT bugs 31919, 11925 (Notebook.pm testing failures) fixed, again thanks to Russ Allbery - UI.pm now uses strict and warnings(!) - UI.pm's POD and layout being overhauled - BUGS and TODO have been nuked (RT, googlecode) Version 0.9602 ============== - Using Module::Install now - Removed effectively null t/99template.t which was causing FAILs for CPAN testers (to be replaced with more testing at a later date) - Apologies for the weird previous version number Version 0.96_01 =============== - Fixed bug in C::UI::Checkbox->get (RT#31916, Russ Allbery) - Fixed doc bug in Tutorial.pod (rt#31918, Russ Allbery) - Fixed doc bug in Checkbox.pm (rt#31917, Russ Allbery) - Began POD overhaul and code reformatting Version 0.96 ============ - Added -keydelay option to new() - Fixed Listbox docs again - Fixed focusing bug in connection with mouse support - Applied patches by Vitaliy Sennikov - Doc patches by Alexey Tourbin - Slovak translation by Marek Grac - Removed test.pl, added note on demos to INSTALL - Removed COLOR_TODO - Added Coverage (Devel::Cover report) Version 0.95 ============ - Fixes to the RT#6770 patch to unbreak listbox - Updated Manifest - Fixes to Dialog Colors by Antonio Gallo - Notebook widget by George Theall Version 0.94 ============ - Some patches by Luke Closs (lukec@activestate.com): - fixed 99template.t - word wrap bug - Language.pm fixes - Dialog labels not-focusable - toggle password mode for text editor - Listbox id() method fix - Query Dialog - Buttonbox patch - Listbox now take arrayrefs as well as arrays as $l->values. (Patch by domi@komarr.grenoble.hp.com RT#6770) - tabbing over the last _enabled_ component did not result in leaving the container if that component was followed by a non focusable component in the focusorder. (Patch by William Barsse RT#7027) - small changes to the pod tests - event_onblur to fix Checkbox behaviour by Joe Oppegaard and lots of POD fixes Version 0.93 ============ - New languages: Turkish, Spanish, Chinese - Doc changes to the tutorial (after a nice review by JC) - Fixed the clear routine to use the build ins (maybe a security issue, because it called the system owns "clear" command) - Added some methods to the Listbox widget - Performance patch by Joe Oppegaard Version 0.92 ============ - Ok, blame me, I'll never ever release some big changes again at "Karneval". I commented out Xterm/Curses mouse support in 0.91. Should work again - Changes to the tests, added test to make 0.90 never happen again and fixed failing tests on no screen platforms Version 0.91 ============ - fixed critical bug with call to a missing sub that should have never happened. Version 0.90 ============ - got an excellent patch by Ralf S. Engelschall to enable inline markup in Listbox and other bugfixes. - Patch by Rupert Northcote-Green and Scott Husek for vertical aligned Buttonboxes - Bugfixes for focusing - Mouse hooks for Curses::UI::Mousehandler::GPM - At least a little bit of resizing support - Hocks for adding events to the mainloop - Added insert_at and add_label to Listbox Version 0.85 ============ - new Widget: Dirbrowser - new tutorial and some doc fixes - italian language updated - a couple of bugfixes Version 0.80 ============ - small fixes to avoid warnings - workaround for a strange win32 compile bug - fixes to polish translation - more tests - small changes to some widgets - color support changes - fixed colors in submenus - fixed colors for status messages - norwegian translation by Vlad Tepes Version 0.75 ============ 2003-07-28 - WE GOT COLOR!!! see Curses::UI::Color for details and the new color_editor demo - added french and portuguese translation - various small changes and fixes - Some work by Raul Dias to fix some focus bugs Version 0.74 ============ 2003-04-27 - Fixed critical bug that broke Menubar selection Version 0.73 ============ 2003-03-28 - Added Russian, Polish, Italian and German language pack - Applied focusdelete and userdata patch by Raul Dias - Fixed unselect for single selects in Listbox - Fixed Solaris 8 Compile bug - Did some documentation work Version 0.72 ============ 2003-03-24 - Maintainer changed, new maintainer is now Marcus Thiesen (MARCUS) <marcus@cpan.thiesenweb.de> - Small bug fix to the delete call that will now work right - Mouse support is now optional - Some additions to the Listbox widget Version 0.71 ============ 2002-02-01 - Darn... the thing did not work correctly on non- ncurses systems. Having things like "BUTTON1_CLICKED" in the code does not work if the Curses module does not have them defined. It should be "BUTTON1_CLICKED()" to avoid warnings like "Bareword "BUTTON1_CLICKED" not allowed..." Solved this in all modules. Thanks to Nick Slussar for noticing. - Added mouse-support to the Calendar widget. - Added language support, so the widget specific language strings are configurable. The language strings are in Curses::UI::Language::<language>.pm. Extra languages can be created by adding a new <language>.pm file over there. Currently I created a Dutch and an English language module. I you create a language module of your own, please send it to me. I'll then include it in the distribution. - Changed all year 2001 occurrances in the Changelog to 2002. Thanks to Mark Overmeer (mr. Mail::Box) for noticing that I was one year off ;-) - Made sure that upon deleting a widget from a container, its subwindows are deleted. - Created calendar dialog (request made by Ravi Pina). Also added a little demo to demo-widgets for this new dialog type. The dialog is accessable via Curses::UI ($cui->calendardialog). - Changed the unpacking of mouse events a little (thanks to William Setzer for the hint on unpack("sx2i3l", $MEVENT) instead of unpack("i5", $MEVENT)). Version 0.70 ============ 2002-01-31 - After a lot of hacking on the resize code I decided to leave it out for now. I can't get things stable :-( I will try to look into this at some other time. - Made a start on the support of mouse events. It's doable! :-) Most widgets now have some sort of mouse event handler. Or widgets should try to focus if clicked upon. - Resolved a whole bunch of small bugs that turned up while building mouse support. 2002-01-29 - Removed automatic resize control. This did not work good on ncurses (crashes). Now, resizing is done after a keypress. - Fixed a bug in the char_read() method. The returncode of the select() call is checked for errors. - Non interacting dialogs (status + progress) are now not focusable anymore. This makes sure that the current window is not blurred. - Fixed bug: the horizontal positioning of the first opened menulistbox from a menubar was wrong. - Renamed some "constants" to prevent future namespace clashes: KEY_ESCAPE => CUI_ESCAPE KEY_SPACE => CUI_SPACE KEY_TAB => CUI_TAB 2002-01-28 - Removed all demo-Curses::UI* examples from the distribution and created a new widget demo: examples/demo-widgets. In this demo all widgets and dialogs are showed. - If you do "make test INTERACTIVE_TEST=1", the widget demo program will be started if all tests were successful. - Fixed examples/pop3_reader for use of the new event system. - <SHIFT-TAB> is now supported to focus the previous object (this will not work on all terminals, but it's a nice-to-have!). - A lot of time is involved in debugging widgets. So I added $Curses::UI::debug which can be set using "new Curses::UI(-debug => 1)". Currently only the pressed keys are sent to STDERR (so you should write STDERR out to a file to use the debugging), but more things might be debugged later on. - Fixed bug: schedule_draw is set to zero if an object loses focus (else the schedule would redraw a widget after the focus change if the focus change was done by a binding routine). - Made setprogress(), noprogress(), nostatus() from Curses::UI flush the input keys. This makes sure that on some systems the output is not buffered as long as there is input waiting and it is generally a good thing to ignore the input that was done during the showing of the dialog. - Removed screenheight tampering from Curses::UI::Widget->windowparameters() which was used for automatically reserving space for the menubar if the application had one. Now I have moved this responsibility to the user. The user should use "-padtop => <value>" if a window should not overlap the menubar. This will let Window centering be real Window centering. This also makes it possible to create a "popup" menubar by letting the main windows draw over the menubar (the menubar will only be visible if it gets the focus). - Widgets now can focus another widget using their event callback routines. Before, the widget would always go to the next or previous widget, but now loose_focus() won't do this if the focus is not on the widget itself anymore. I'm not sure if it works for all widgets already, but I needed it to be able to use the menubar to shift focus between windows. 2002-01-27 - Renamed the 'return' binding in all widgets to 'loose-focus'. This makes much more sense in the new event system (in the old event system a widget would actually return a value when the 'return' binding was called). - Renamed the '-homeonreturn' option for TextEditor and its descendants to '-homeonblur' for the same reason as mentioned above. - The buttonbox will handle the TAB key different than before. Now it will cycle through the buttons. If the last button is selected and TAB is pressed, the total Buttonbox will loose focus. This is much more like the behaviour that a user would expect. - Fixed a layout bug in Dialog::Basic (if the buttonwidth was larger than the messagewidth, a 'screen not large enough' error would show). - Fixed a bug in FileBrowser.pm. The popupbox in the FileBrowser window was still built for the old event system. Now it has an -onchange event which reloads the file list. Also, the focus will not longer go to the buttons, but to the filelistbox or the fileentry field if -editfilename is set to a true value. 2002-01-26 - Reading keys is not done anymore using the halfdelay function of curses. Now a select() call is used to determine if there is input waiting. - The timeout for reading a key is now depending upon the smallest active timed event interval. If there are no active timed events at all, the timeout will be -1, which causes a full blocking read. In this way as little as possible resources are used. - -windowscr, screenwidth and screenheight were a little bit too cryptic I think. These are now renamed to -canvasscr, canvaswidth and canvasheight. - Fixed bug in Searchable.pm (cursor was not visible during search). - Switched testing to Test::Harness (t/*.t) - Buttonbox now also has Curses::UI->fatalerror() in case of an illegal button definition. - Curses::UI now checks if there is only one instance of Curses:UI and it now exports MainLoop() (just for fun, it is like the Tk MainLoop function). 2002-01-25 - Fixed some problems with modal focused windows. - The Popupmenu widget now also works. This widget is partly rewritten to make it more clean and make it fit in the new event system. - New method: Curses::UI->fatalerror( [error] ). This will display a fatal error to the user. After pressing a key, the program will exit. This is usefull in places where you would otherwise use die() (or one of its Carp friends). - Moved usemodule() from the Container package to Curses::UI. This method now honours the %INC hash, which means less on-the-fly loading of modules will occur. - Made searching through listboxes and textviewers possible in the new event system. - Fixed some -onchange event bugs in popupmenu. till 2002-01-24 - The complete event structure is set upside-down. By using this new event structure, timed routines and mouse events are possibilities. Maybe even integration with POE! :-) (but I haven't looked into that enough to be sure). We also have a Tk-like mainloop() now. - Updated a lot of widgets to support the new event structure (central mainloop in Curses::UI which delegates events). This means that a widget has a event_keypress() method, which handles delegated keypresses. Version 0.64 ============ 2002-01-19: - Started on building a complete new event handling system. This should simplify a couple of things and it should enable new features like some kind of time loop and mouse events. Version 0.63 ============ 2002-01-16: - Added a CLASS HIERARCHY section to the documentation of each Curses::UI class. - All focusable objects now have the following event callbacks: -onfocus / onFocus() -onblur / onBlur() - The Curses::UI::Calendar widget now fully supports the years 0 - 9999, including the transition from the Julian to the Gregorian calendar (september 1752). This beats the use of timelocal/localtime (which would currently only support 1900 - 2038 IIRC). - Added intellidraw() method to Curses::UI::Widget. If this method is called, the widget is redrawn, but only if it's visible (not hidden and in topwindow) and if intellidraw is enabled (-intellidraw data member has a true value). This routine can be used to be able to redraw widgets on a status change, without having to figure out yourself if this wouldn't clutter up the screen. The -intellidraw option is meant for widget builders (see for example the Checkbox code). - Incorporated intellidraw() method in: - Curses::UI::Window - Curses::UI::Label - Curses::UI::Calendar - Curses::UI::Buttonbox - Curses::UI::Listbox (+ descendants) - Curses::UI::Checkbox - Curses::UI::Popupbox - Curses::UI::Progressbar - Curses::UI::TextEditor (+ descendants) - Curses::UI::SearchEntry - Added a little example application to demonstrate the new intellidraw feature: examples/demo-intellidraw 2002-01-15: - Changed the displaying of the calendar widget a little. The topbar showing a date is only highlighted if the cursor is on the selected date. - Renamed some widgets (now we still can). I think there are too many capitals in them... - Curses::UI::ListBox renamed to Curses::UI::Listbox - Curses::UI::CheckBox renamed to Curses::UI::Checkbox - Curses::UI::MenuBar renamed to Curses::UI::Menubar - Curses::UI::MenuListBox renamed to Curses::UI::MenuListbox - Curses::UI::PopupBox renamed to Curses::UI::Popupmenu - Curses::UI::ProgressBar renamed to Curses::UI::Progressbar - Curses::UI::ButtonBox renamed to Curses::UI::Buttonbox - Curses::UI::RadioButtonBox renamed to Curses::UI::Radiobuttonbox - Curses::UI::Dialog::FileBrowser renamed to Curses::UI::Dialog::Filebrowser - Added event callbacks to: - Curses::UI::Calendar (-onchange / onChange()) - Curses::UI::Listbox (-onchange / onChange()) - Curses::UI::Checkbox (-onchange / onChange()) - Curses::UI::TextEditor (-onchange / onChange()) - Curses::UI::TextEntry (-onchange / onChange()) - Curses::UI::PasswordEntry (-onchange / onChange()) - Curses::UI::Popupmenu (-onchange / onChange()) - The options that can be passed to the new() methods, are case insensitive now. So it is perfectly okay to write: $win->add( 'cb', 'Checkbox', -Label => 'Demonstration widget', -onChange => sub { exit() } ); Version 0.62 ============ 2002-01-14: - Changed the Label widget. The text to show on the widget may contain more than one line of text (so newline characters may be used). The status-dialog is changed accordingly. Other widgets that use Labels are not updated yet. - Updated Curses::UI::Dialog::Progress for use with the new Label widget. - Fixed a layout bug in Curses::UI::Widget (the available height and width were incorrectly computed when using negative -x and -y offsets). - Renamed Curses::UI::Buttons to Curses::UI::Buttonbox, which is more like the naming of the rest of the widget set. Updated all examples and wigets for this change. - Fixed some undefined value warnings in Curses::UI::Dialog::Filebrowser. - Incorporated multi-line label support in the checkbox widget. - Added new widgets + documentation: - Curses::UI::PasswordEntry - Curses::UI::Calendar - Added new example applications: - demo-Curses::UI::Calendar 2002-01-13: - Changed the way the buttons are defined in Curses::UI::Buttons (all information is now in the -buttons option and there are predefined button types). The documentation for Curses::UI::Buttons is updated. - Buttons can now have a -onpress event assigned to them. This callback will execute after the button is pressed and before the focus is lost. - All examples are updated for the changed Curses::UI::Buttons class. - Solved a warning for some versions of perl about a prototype. - Fixed some documentation typos. Version 0.61 ============ 2002-01-13: - Extended the examples/basic_test file to test the functionality of the basic widgets (for now: Label, Buttons, Checkbox, Listbox, Popupbox, Progressbar and TextEditor). Directly derived widgets are not tested (like Radiobuttonbox and TextEntry) because these will most probably work like they should if the base class is okay. - Changed the structure of the checkbox widget. The layout() method would each time re-add the label widget to the checkbox widget. Now the checkbox is a container derivate which always contains the label. - Fixed bug: The TextEditor class and derivates didn't call check_for_resize() during focus, so screen resize was not detected. 2002-01-12: - Fixed some broken links in the documentation. - Removed "use Carp qw(confess)" from the modules which do not use this (anymore). - Wrote documentation for: - Curses::UI::Dialog::Basic - Curses::UI::Dialog::Error - Curses::UI::Dialog::Filebrowser - Curses::UI::Dialog::Progress - Curses::UI::Dialog::Status - Added new example applications: - demo-Curses::UI::Dialog::Filebrowser - demo-Curses::UI::Dialog::Status - Added the -clear_on_exit option to Curses::UI. If this option is set, a Curses::UI application will call "clear" on exit. Version 0.60 ============ 2002-01-11: - Wrote documentation for: - Curses::UI::MenuListbox - Curses::UI::Menubar - Added new example application: - demo-Curses::UI::Menubar 2002-01-10: - Wrote documentation for: - Curses::UI::TextEditor - Curses::UI::TextEntry - Curses::UI::TextViewer - Curses::UI::Common - Curses::UI::Container - Added new example applications: - demo-Curses::UI::Dialog::Basic - demo-Curses::UI::TextEditor - New option for Curses::UI::Label: -paddingspaces 2002-01-09: - If the screen is too small for the application to show, the program will no longer die. Now it will show a message telling the user that the screen should be bigger. - Added the -compat option and compat() method to Curses::UI. If -compat is set to a true value, the Curses::UI widgets will be draw using only basic characters, which should be available on all terminals. This might be a good option for terminals which do not have characters like ACS_VLINE and ACS_HLINE. - Changed the -viewmode of Curses::UI::TextEditor to -readonly. - The setpos() method of Curses::UI::Progressbar has been renamed to pos(). The options -showpercentage and -showcenterline have been changed to -nopercentage and -nocenterline. - Wrote documentation for: - Curses::UI::Popupbox - Curses::UI::Progressbar - Curses::UI::SearchEntry - Curses::UI::Searchable - Added new example applications: - demo-Curses::UI::Popupbox - demo-Curses::UI::Progressbar 2002-01-08: - Deleted last references to the old mws (Maurice's Widget Set) namespace from the modules. - Wrote documentation for: - Curses::UI::Checkbox - Curses::UI::Label - Curses::UI::Listbox - Added new example applications: - demo-Curses::UI::Checkbox - demo-Curses::UI::Label - demo-Curses::UI::Listbox Version 0.56 ============ 2002-01-07: - Added new example applications: - hello_world - demo-Curses::UI::Buttons - demo-Curses::UI::Dialog::Progress - pop3_reader: a simple POP3 mail reader - Wrote documentation for Curses::UI::Buttons - New constants in Common.pm: KEY_TAB, KEY_SPACE - Moved the following methods from Common.pm to Widget.pm: - clear_binding() - set_routine() - set_binding() - process_bindings() - generic_focus() 2002-01-07: - Dialogs are moved to their own namespace: Curses::UI::Dialog. - Curses::UI has two new filebrowser dialog methods: loadfilebrowser() and savefilebrowser(). These are filebrowser dialogs which are setup correctly for loading and saving files. The savefilebrowser() will also check if the file to save to does exist. If it does it will show a confirmation dialog to have the user confirm that the file may be overwritten. - The code for centering a Window is now in the Curses::UI::Window class. If the option -centered is set, the layout() method will center the Window. - The add() routines of the classes Curses::UI and Curses::UI::Container will not also accept "Dialog::*" as a shortcut for "Curses::UI::Dialog::*". - Added a new dialog: Curses::UI::Dialog::Status and added documentation and and example to Curses::UI. - Added a new dialog: Curses::UI::Dialog::Progress and added documentation and and example to Curses::UI. - Curses::UI applications will now automatically clear the screen on exit (by calling the 'clear' program using a safe $PATH). Version 0.55 ============ 2002-01-06: - Instead of: $thingy->add('id', 'Curses::UI::WidgetType', %args) You may now also write: $thingy->add('id', 'WidgetType', %args) If there are no double colons in the class name, the sofware assumes the class is in Curses::UI. - Wrote documentation for Curses::UI. - Fixed some small bugs and did some code cleanup. 2002-01-05: - Included basic_test in test.pl, so a real use of the package is tested. - The Curses::UI::RootWindow does not exist anymore. Now the rootlevel for Curses::UI is created using "my $cui = new Curses::UI". - Finished first version of documentation for Curses::UI::Widget. Version 0.54 ============ 2002-01-04: - Some small changes in the examples and a new example (basic_test) added. - Added -show_hidden option to the Filebrowser. - Added ~ keybinding to the Filebrowser. If ~ is pressed in the directory- or filebrowser, the Filebrowser will go to the homedirectory of the current user. - If at creation time of the Filebrowser, the -path is not defined, the Filebrowser will start at the homedirectory of the user. - The Curses::UI::Frame class is now called Curses::UI::Widget. - Solved a bug in Curses::UI::Common::delallwin() which caused a segmentation fault on some systems (by doing a delwin on an already deleted curses window). - Made a test.pl to test the loading of all classes. - Updated Makefile.PL, so required modules are checked. - Made a start on documenting Curses::UI. The first bit of documentation is in Curses::UI::Widget. More will follow. Version 0.53 ============ 2002-01-03: - Initial import to CPAN. �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/MANIFEST���������������������������������������������������������������������������0000644�0001750�0000144�00000004354�11627564365�013436� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Changes CREDITS examples/color_editor examples/demo-add examples/demo-buttonbox examples/demo-color examples/demo-cuml examples/demo-language examples/demo-notebook examples/demo-widgets examples/editor examples/hello_world examples/mouse_focustest examples/pop3_reader examples/tutorial inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm INSTALL lib/Curses/UI.pm lib/Curses/UI/Buttonbox.pm lib/Curses/UI/Calendar.pm lib/Curses/UI/Checkbox.pm lib/Curses/UI/Color.pm lib/Curses/UI/Common.pm lib/Curses/UI/Container.pm lib/Curses/UI/Dialog/Basic.pm lib/Curses/UI/Dialog/Calendar.pm lib/Curses/UI/Dialog/Dirbrowser.pm lib/Curses/UI/Dialog/Error.pm lib/Curses/UI/Dialog/Filebrowser.pm lib/Curses/UI/Dialog/Progress.pm lib/Curses/UI/Dialog/Question.pm lib/Curses/UI/Dialog/Status.pm lib/Curses/UI/Label.pm lib/Curses/UI/Language.pm lib/Curses/UI/Language/chinese.pm lib/Curses/UI/Language/czech.pm lib/Curses/UI/Language/dutch.pm lib/Curses/UI/Language/english.pm lib/Curses/UI/Language/french.pm lib/Curses/UI/Language/german.pm lib/Curses/UI/Language/italian.pm lib/Curses/UI/Language/japanese.pm lib/Curses/UI/Language/norwegian.pm lib/Curses/UI/Language/polish.pm lib/Curses/UI/Language/portuguese.pm lib/Curses/UI/Language/russian.pm lib/Curses/UI/Language/slovak.pm lib/Curses/UI/Language/spanish.pm lib/Curses/UI/Language/turkish.pm lib/Curses/UI/Listbox.pm lib/Curses/UI/Menubar.pm lib/Curses/UI/Notebook.pm lib/Curses/UI/PasswordEntry.pm lib/Curses/UI/Popupmenu.pm lib/Curses/UI/Progressbar.pm lib/Curses/UI/Radiobuttonbox.pm lib/Curses/UI/Searchable.pm lib/Curses/UI/TextEditor.pm lib/Curses/UI/TextEntry.pm lib/Curses/UI/TextViewer.pm lib/Curses/UI/Tutorial.pod lib/Curses/UI/Widget.pm lib/Curses/UI/Window.pm Makefile.PL MANIFEST This list of files META.yml README t/01base_classes.t t/02widget_classes.t t/03dialog_classes.t t/04language_classes.t t/05pod.t t/06ui.t t/07widget.t t/08common.t t/09label.t t/10texteditor.t t/11listbox.t t/12gpm_handler.t t/13notebook.t t/99misc.t t/fakelib/Curses.pm t/lorem.pl ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/�������������������������������������������������������������������������������0000755�0001750�0000144�00000000000�11630214052�013023� 5����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/������������������������������������������������������������������������0000755�0001750�0000144�00000000000�11630214052�014250� 5����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/����������������������������������������������������������������0000755�0001750�0000144�00000000000�11630214052�015656� 5����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/Makefile.pm�����������������������������������������������������0000644�0001750�0000144�00000027032�11630214033�017734� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; <MAKEFILE> }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/Include.pm������������������������������������������������������0000644�0001750�0000144�00000001015�11630214033�017573� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/Base.pm���������������������������������������������������������0000644�0001750�0000144�00000002147�11630214033�017071� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.01'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/AutoInstall.pm��������������������������������������������������0000644�0001750�0000144�00000003632�11630214033�020456� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; ������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/Metadata.pm�����������������������������������������������������0000644�0001750�0000144�00000043123�11630214033�017736� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E<lt>}{<}g; $author =~ s{E<gt>}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/WriteAll.pm�����������������������������������������������������0000644�0001750�0000144�00000002376�11630214034�017747� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/Win32.pm��������������������������������������������������������0000644�0001750�0000144�00000003403�11630214034�017116� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/Fetch.pm��������������������������������������������������������0000644�0001750�0000144�00000004627�11630214034�017256� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; ���������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install/Can.pm����������������������������������������������������������0000644�0001750�0000144�00000003333�11630214034�016717� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/Install.pm��������������������������������������������������������������0000644�0001750�0000144�00000030135�11630214033�016215� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.01'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; <FH> }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; <FH> }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2011 Adam Kennedy. �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/inc/Module/AutoInstall.pm����������������������������������������������������������0000644�0001750�0000144�00000054231�11630214033�017051� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _load($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while (<FAILED>) { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) : CPAN::Shell->install($pkg); $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1071 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/��������������������������������������������������������������������������0000755�0001750�0000144�00000000000�11630214052�014070� 5����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/tutorial������������������������������������������������������������������0000755�0001750�0000144�00000002246�11627564365�015712� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # Tutorial example # 2003 (c) by Marcus Thiesen (marcus@cpan.org) # This file is a part of Curses::UI and might be distributed # under the same terms as perl itself. # Use the libraries from the distribution, instead of # system wide libraries. use FindBin; use lib "$FindBin::RealBin/../lib"; use strict; use Curses::UI; my $cui = new Curses::UI( -color_support => 1 ); my @menu = ( { -label => 'File', -submenu => [ { -label => 'Exit ^Q', -value => \&exit_dialog } ] }, ); my $menu = $cui->add( 'menu','Menubar', -menu => \@menu, -fg => "blue", ); my $win1 = $cui->add( 'win1', 'Window', -border => 1, -y => 1, -bfg => 'red', ); sub exit_dialog() { my $return = $cui->dialog( -message => "Do you really want to quit?", -title => "Are you sure???", -buttons => ['yes', 'no'], ); exit(0) if $return; } my $texteditor = $win1->add("text", "TextEditor", -text => "Here is some text\n" . "And some more"); $cui->set_binding(sub {$menu->focus()}, "\cX"); $cui->set_binding( \&exit_dialog , "\cQ"); $texteditor->focus(); $cui->mainloop(); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/demo-widgets��������������������������������������������������������������0000755�0001750�0000144�00000063644�11627564365�016450� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w use strict; use File::Temp qw( :POSIX ); use lib "../lib"; # make KEY_BTAB (shift-tab) working in XTerm # and also at the same time enable colors #$ENV{TERM} = "xterm-vt220" if ($ENV{TERM} eq 'xterm'); my $debug = 0; if (@ARGV and $ARGV[0] eq '-d') { my $fh = tmpfile(); open STDERR, ">&fh"; $debug = 1; } else { # We do not want STDERR to clutter our screen. my $fh = tmpfile(); open STDERR, ">&fh"; } use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; # Create the root object. my $cui = new Curses::UI ( -clear_on_exit => 1, -debug => $debug, ); # Demo index my $current_demo = 1; # Demo windows my %w = (); # ---------------------------------------------------------------------- # Create a menu # ---------------------------------------------------------------------- sub select_demo($;) { my $nr = shift; $current_demo = $nr; $w{$current_demo}->focus; } my $file_menu = [ { -label => 'Quit program', -value => sub {exit(0)} }, ], my $widget_demo_menu = [ { -label => 'Label', -value => sub{select_demo(1)} }, { -label => 'Buttons', -value => sub{select_demo(2)} }, { -label => 'Checkbox', -value => sub{select_demo(3)} }, { -label => 'Texteditor', -value => sub{select_demo(4)} }, { -label => 'Listbox', -value => sub{select_demo(5)} }, { -label => 'Popupmenu', -value => sub{select_demo(6)} }, { -label => 'Progressbar', -value => sub{select_demo(7)} }, { -label => 'Calendar', -value => sub{select_demo(8)} }, ]; my $dialog_demo_menu = [ { -label => 'Basic dialog', -value => sub{select_demo(9)} }, { -label => 'Error dialog', -value => sub{select_demo(10)} }, { -label => 'Filebrowser dialog', -value => sub{select_demo(11)} }, { -label => 'Progress dialog', -value => sub{select_demo(12)} }, { -label => 'Status dialog', -value => sub{select_demo(13)} }, { -label => 'Calendar dialog', -value => sub{select_demo(14)} }, { -label => 'Question dialog', -value => sub{select_demo(15)} }, ]; my $demo_menu = [ { -label => 'Widget demos', -submenu => $widget_demo_menu }, { -label => 'Dialog demos', -submenu => $dialog_demo_menu }, { -label => '------------', -value => sub{} }, { -label => 'Next demo', -value => \&goto_next_demo }, { -label => 'Previous demo', -value => \&goto_prev_demo }, ]; my $menu = [ { -label => 'File', -submenu => $file_menu }, { -label => 'Select demo', -submenu => $demo_menu }, ]; $cui->add('menu', 'Menubar', -menu => $menu); # ---------------------------------------------------------------------- # Create the explanation window # ---------------------------------------------------------------------- my $w0 = $cui->add( 'w0', 'Window', -border => 1, -y => -1, -height => 3, ); $w0->add('explain', 'Label', -text => "CTRL+P: previous demo CTRL+N: next demo " . "CTRL+X: menu CTRL+Q: quit" ); # ---------------------------------------------------------------------- # Create the demo windows # ---------------------------------------------------------------------- my %screens = ( '1' => 'Label', '2' => 'Buttons', '3' => 'Checkbox', '4' => 'Texteditor', '5' => 'Listbox', '6' => 'Popupmenu', '7' => 'Progressbar', '8' => 'Calendar', '9' => 'Basic dialog', '10' => 'Error dialog', '11' => 'Filebrowser dialog', '12' => 'Progress dialog', '13' => 'Status dialog', '14' => 'Calendar dialog', '15' => 'Question dialog', ); my @screens = sort {$a<=>$b} keys %screens; my %args = ( -border => 1, -titlereverse => 0, -padtop => 2, -padbottom => 3, -ipad => 1, ); while (my ($nr, $title) = each %screens) { my $id = "window_$nr"; $w{$nr} = $cui->add( $id, 'Window', -title => "Curses::UI demo: $title ($nr/" . @screens . ")", %args ); } # ---------------------------------------------------------------------- # Label demo # ---------------------------------------------------------------------- $w{1}->add( undef, 'Label', -text => "A label is a widget which can be used to display\n" . "a piece of text. This text can be formatted. The\n" . "supported formats are shown below. It depends upon\n" . "your terminal if all formats are shown correctly." ); $w{1}->add(undef,'Label',-text=>"dim font",-y=>5,-dim=>1 ); $w{1}->add(undef,'Label',-text=>"bold font",-y=>7,-bold=>1 ); $w{1}->add(undef,'Label',-text=>"reversed font",-y=>9,-reverse => 1 ); $w{1}->add(undef,'Label',-text=>"underlined font",-x=>15,-y=>5,-underline=>1 ); $w{1}->add(undef,'Label',-text=>"blinking font",-x=>15,-y=>7,-blink=>1 ); # ---------------------------------------------------------------------- # Buttons demo # ---------------------------------------------------------------------- $w{2}->add( undef, 'Label', -text => "The buttons widget displays an array of buttons.\n" . "As you would have guessed, these buttons can be pressed.\n" . "Select a button using <TAB>, the arrow keys or <H> and <L>\n" . "and press a button using the <SPACE> or <ENTER> key." ); $w{2}->add( 'buttonlabel', 'Label', -y => 7, -width => -1, -bold => 1, -text => "Press a button please...", ); sub button_callback($;) { my $this = shift; my $label = $this->parent->getobj('buttonlabel'); $label->text("You pressed: " . $this->get); } $w{2}->add( undef, 'Buttonbox', -y => 5, -buttons => [ { -label => "< Button 1 >", -value => "the first button", -onpress => \&button_callback, },{ -label => "< Button 2 >", -value => "the second button", -onpress => \&button_callback, },{ -label => "< Button 3 >", -value => "the third button", -onpress => \&button_callback, }, ], ); # ---------------------------------------------------------------------- # Checkbox demo # ---------------------------------------------------------------------- $w{3}->add( undef, 'Label', -text => "The checkbox can be used for selecting a true or false\n" . "value. If the checkbox is checked (a 'X' is inside it)\n" . "the value is true. <SPACE> and <ENTER> will toggle the\n" . "state of the checkbox, <Y> will check it and <N> will\n" . "uncheck it." ); my $cb_no = "The checkbox says: I don't like it :-("; my $cb_yes = "The checkbox says: I do like it! :-)"; $w{3}->add( 'checkboxlabel', 'Label', -y => 8, -width => -1, -bold => 1, -text => "Check the checkbox please...", ); $w{3}->add( undef, 'Checkbox', -y => 6, -checked => 0, -label => 'I like this Curses::UI demo so far!', -onchange => sub { my $cb = shift; my $label = $cb->parent->getobj('checkboxlabel'); $label->text($cb->get ? $cb_yes : $cb_no); }, ); # ---------------------------------------------------------------------- # Texteditor demo # ---------------------------------------------------------------------- $w{4}->add( undef, 'Label', -text => "The texteditor can be used for entering lines or blocks\n" . "of text. It also can be used in read-only mode as a\n" . "textviewer. Below you see some of the possibilities that\n" . "the texteditor widget offers." ); $w{4}->add( 'te1', 'TextEditor', -title => 'not wrapping', -y => 5, -width => 20, -border => 1, -padbottom => 4, -vscrollbar => 1, -hscrollbar => 1, -onChange => sub { my $te1 = shift; my $te2 = $te1->parent->getobj('te2'); my $te3 = $te1->parent->getobj('te3'); $te2->text($te1->get); $te3->text($te1->get); $te2->pos($te1->pos); }, ); $w{4}->add( 'te2', 'TextEditor', -title => 'wrapping', -y => 5, -x => 21, -width => 20, -border => 1, -padbottom => 4, -vscrollbar => 1, -hscrollbar => 1, -wrapping => 1, -onChange => sub { my $te2 = shift; my $te1 = $te2->parent->getobj('te1'); my $te3 = $te2->parent->getobj('te3'); $te1->text($te2->get); $te3->text($te2->get); $te1->pos($te2->pos); }, ); $w{4}->add( 'te3', 'TextViewer', -y => 5, -x => 42, -width => 20, -border => 1, -padbottom => 4, -title => "Read only", -vscrollbar => 1, -hscrollbar => 1, ); $w{4}->add( undef, 'Label', -y => -3, -text => "Single line entry:", -width => 20, ); $w{4}->add( undef, 'TextEntry', -sbborder => 1, -y => -3, -x => 21, -width => 20, ); $w{4}->add( undef, 'Label', -y => -1, -text => "Password entry:", -width => 20, ); $w{4}->add( undef, 'PasswordEntry', -sbborder => 1, -y => -1, -x => 21, -width => 20, ); # ---------------------------------------------------------------------- # Listbox demo # ---------------------------------------------------------------------- my $values = [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ]; my $labels = { 1 => 'One', 2 => 'Two', 3 => 'Three', 4 => 'Four', 5 => 'Five', 6 => 'Six', 7 => 'Seven', 8 => 'Eight', 9 => 'Nine', 10 => 'Ten', }; $w{5}->add( undef, 'Label', -text => "The listbox can be used for selecting on or more options\n" . "out of a predefined list of options. <SPACE> and <ENTER> will\n" . "change the current selected option for a normal listbox and a\n" . "radiobuttonbox, They will toggle the state of the active option in\n" . "a multi-select listbox. In a multi-select listbox you can also\n" . "use <Y> and <N> to check or uncheck options. Press </> for a\n" . "'less'-like search through the list." ); sub listbox_callback() { my $listbox = shift; my $label = $listbox->parent->getobj('listboxlabel'); my @sel = $listbox->get; @sel = ('<none>') unless @sel; my $sel = "selected: " . join (", ", @sel); $label->text($listbox->title . " $sel"); } $w{5}->add( undef, 'Listbox', -y => 8, -padbottom => 2, -values => $values, -labels => $labels, -width => 20, -border => 1, -title => 'Listbox', -vscrollbar => 1, -onchange => \&listbox_callback, ); $w{5}->add( undef, 'Listbox', -y => 8, -padbottom => 2, -x => 21, -values => $values, -labels => $labels, -width => 20, -border => 1, -multi => 1, -title => 'Multi-select', -vscrollbar => 1, -onchange => \&listbox_callback, ); $w{5}->add( undef, 'Radiobuttonbox', -y => 8, -padbottom => 2, -x => 42, -values => $values, -labels => $labels, -width => 20, -border => 1, -title => 'Radiobuttonbox', -vscrollbar => 1, -onchange => \&listbox_callback, ); $w{5}->add( 'listboxlabel', 'Label', -y => -1, -bold => 1, -text => "Select any option in one of the listboxes please....", -width => -1, ); # ---------------------------------------------------------------------- # Popupmenu # ---------------------------------------------------------------------- $w{6}->add( undef, 'Label', -text => "The popmenu is much like a standard listbox. The difference is\n" . "that only the currently selected value is visible (or ---- if\n" . "no value is yet selected). The list of possible values will be\n" . "shown as a separate popup windows if requested.\n" . "Press <ENTER> or <CURSOR-RIGHT> to open the popupbox and use\n" . "those same keys to select a value (or use <CURSOR-LEFT> to close\n" . "the popup listbox without selecting a value from it). Press\n" . "</> in the popup for a 'less'-like search through the list." ); $w{6}->add( undef, 'Popupmenu', -y => 9, -values => $values, -labels => $labels, -width => 20, -onchange => sub { my $pm = shift; my $lbl = $pm->parent->getobj('popupmenulabel'); my $val = $pm->get; $val = "<undef>" unless defined $val; my $lab = $pm->{-labels}->{$val}; $val .= " (label = '$lab')" if defined $lab; $lbl->text($val); $lbl->draw; }, ); $w{6}->add( undef, 'Label', -y => 9, -x => 21, -text => "--- selected --->" ); $w{6}->add( 'popupmenulabel', 'Label', -y => 9, -x => 39, -width => -1, -bold => 1, -text => "none" ); # ---------------------------------------------------------------------- # Progressbar # ---------------------------------------------------------------------- $w{7}->add( 'progressbarlabel', 'Label', -x => -1, -y => 3, -width => 10, -border => 1, -text => "the time" ); $w{7}->add( undef, 'Label', -text => "The progressbar can be used to provide some progress information\n" . "to the user of a program. Progressbars can be drawn in several\n" . "ways (see below for a couple of examples). In this example, I\n" . "just built a kind of clock (the values for the bars are \n" . "depending upon the current time)." ); $w{7}->add( undef, "Label", -y => 7, -text => "Showing value"); $w{7}->add( 'p1', 'Progressbar', -max => 24, -x => 15, -y => 6, -showvalue => 1 ); $w{7}->add( undef, "Label", -y => 10, -text => "No centerline"); $w{7}->add( 'p2', 'Progressbar', -max => 60, -x => 15, -y => 9, -nocenterline => 1 ); $w{7}->add( undef, "Label", -y => 13, -text => "No percentage"); $w{7}->add( 'p3', 'Progressbar', -max => 60, -x => 15, -y => 12, -nopercentage => 1 ); sub progressbar_timer_callback($;) { my $cui = shift; my @l = localtime; $w{7}->getobj('p1')->pos($l[2]); $w{7}->getobj('p2')->pos($l[1]); $w{7}->getobj('p3')->pos($l[0]); $w{7}->getobj('progressbarlabel')->text( sprintf("%02d:%02d:%02d", @l[2,1,0]) ); } $cui->set_timer( 'progressbar_demo', \&progressbar_timer_callback, 1 ); $cui->disable_timer('progressbar_demo'); $w{7}->onFocus( sub{$cui->enable_timer ('progressbar_demo')} ); $w{7}->onBlur( sub{$cui->disable_timer ('progressbar_demo')} ); # ---------------------------------------------------------------------- # Calendar # ---------------------------------------------------------------------- $w{8}->add( undef, 'Label', -text => "The calendar can be used to select a date, somewhere between\n" . "the years 0 and 9999. It honours the transition from the\n" . "Julian- to the Gregorian calender in 1752." ); $w{8}->add( undef, 'Label', -y => 5, -x => 27, -text => "Use your cursor keys (or <H>, <J>, <K> and <L>)\n" . "to walk through the calender. Press <ENTER>\n" . "or <SPACE> to select a date. Press <SHIFT+J> to\n" . "go one month forward and <SHIFT+K> to go one\n" . "month backward. Press <SHIFT+L> or <N> to go one\n" . "year forward and <SHIFT+H> or <P> to go one year\n" . "backward. Press <T> to go to today's date. Press\n" . "<C> to go to the currently selected date." ); $w{8}->add( 'calendarlabel', 'Label', -y => 14, -x => 27, -bold => 1, -width => -1, -text => 'Select a date please...' ); $w{8}->add( 'calendar', 'Calendar', -y => 4, -x => 0, -border => 1, -onchange => sub { my $cal = shift; my $label = $cal->parent->getobj('calendarlabel'); $label->text("You selected the date: " . $cal->get); }, ); # ---------------------------------------------------------------------- # Dialog::Basic # ---------------------------------------------------------------------- $w{9}->add( undef, 'Label', -text => "Curses::UI has a number of ready-to-use dialog windows.\n" . "The basic dialog is one of them. It consists of a dialog\n" . "showing a message and one or more buttons. Press the\n" . "buttons to see some examples of this." ); $w{9}->add( undef, 'Buttonbox', -y => 7, -buttons => [ { -label => "< Example 1 >", -onpress => sub { shift()->root->dialog("As basic as it gets") } },{ -label => "< Example 2 >", -onpress => sub { shift()->root->dialog( -message => "Basic, but carrying a\n" . "title this time.", -title => 'Dialog::Basic demo', ); } },{ -label => "< Example 3 >", -onpress => sub { my $b = shift(); my $value = $b->root->dialog( -message => "Basic, but carrying a\n" . "title and multiple buttons.", -buttons => ['ok','cancel', 'yes', 'no'], -title => 'Dialog::Basic demo', ); $b->root->dialog( -message => "The value for that\n" . "button was: $value", -title => "Value?" ); } } ], ); # ---------------------------------------------------------------------- # Dialog::Error # ---------------------------------------------------------------------- $w{10}->add( undef, 'Label', -text => "Curses::UI has a number of ready-to-use dialog windows.\n" . "The Error dialog is one of them. It consists of a dialog\n" . "showing an errormessage, an ASCII art exclamation sign\n" . "and one or more buttons. Press the buttons to see some\n" . "examples of this." ); $w{10}->add( undef, 'Buttonbox', -y => 7, -buttons => [ { -label => "< Example 1 >", -onpress => sub { shift()->root->error("Some error occurred, I guess...") } },{ -label => "< Example 2 >", -onpress => sub { shift()->root->error( -message => "Unfortunately this program is\n" . "unable to cope with the enless\n" . "stream of bugs the programmer\n" . "has induced!!!!", -title => 'Serious trouble', ); } },{ -label => "< Example 3 >", -onpress => sub { my $b = shift(); my $value = $b->root->error( -message => "General error somewhere in the program\n" . "Are you sure you want to continue?", -buttons => ['yes', 'no'], -title => 'Vague problem detected', ); $b->root->dialog( -message => "You do " . ($value?'':'not ') . "want to continue.", -title => "What did you answer?" ); } } ], ); # ---------------------------------------------------------------------- # Dialog::Filebrowser # ---------------------------------------------------------------------- $w{11}->add( undef, 'Label', -text => "Curses::UI has a number of ready-to-use dialog windows.\n" . "The Filebrowser dialog is one of them. Using this dialog\n" . "it is possible to select a file anywhere on the file-\n" . "system. Press the buttons below for a demo" ); $w{11}->add( undef, 'Buttonbox', -y => 7, -buttons => [ { -label => "< Load file >", -onpress => sub { my $cui = shift()->root; my $file = $cui->loadfilebrowser( -title => "Select some file", -mask => [ ['.', 'All files (*)' ], ['\.txt$', 'Text files (*.txt)' ], ['\.pm$', 'Perl modules (*.pm)'], ], ); $cui->dialog("You selected the file:\n$file") if defined $file; } },{ -label => "< Save file (is fake) >", -onpress => sub { my $cui = shift()->root; my $file = $cui->savefilebrowser("Select some file"); $cui->dialog("You selected the file:\n$file") if defined $file; } } ] ); # ---------------------------------------------------------------------- # Dialog::Progress # ---------------------------------------------------------------------- $w{12}->add( undef, 'Label', -text => "Curses::UI has a number of ready-to-use dialog windows.\n" . "The Progress dialog is one of them. Using this dialog\n" . "it is possible to present some progress information to\n" . "the user. Press the buttons below for a demo." ); $w{12}->add( undef, 'Buttonbox', -y => 7, -buttons => [ { -label => "< Example 1 >", -onpress => sub { $cui->progress( -min => 0, -max => 700, -title => 'Progress dialog without a message', -nomessage => 1, ); for my $pos (0..700) { $cui->setprogress($pos); } sleep 1; $cui->noprogress; } },{ -label => "< Example 2 >", -onpress => sub { my $msg = "Counting from 0 to 700...\n"; $cui->progress( -min => 0, -max => 700, -title => 'Progress dialog with a message', -message => $msg, ); for my $pos (0..700) { $cui->setprogress($pos, $msg . $pos . " / 700"); } $cui->setprogress(undef, "Finished counting!"); sleep 1; $cui->noprogress; } } ] ); # ---------------------------------------------------------------------- # Dialog::Status # ---------------------------------------------------------------------- $w{13}->add( undef, 'Label', -text => "Curses::UI has a number of ready-to-use dialog windows.\n" . "The Status dialog is one of them. Using this dialog\n" . "it is possible to present some status information to\n" . "the user. Press the buttons below for a demo." ); $w{13}->add( undef, 'Buttonbox', -y => 7, -buttons => [ { -label => "< Example 1 >", -onpress => sub { $cui->status("This is a status dialog..."); sleep 1; $cui->nostatus; } },{ -label => "< Example 2 >", -onpress => sub { $cui->status("A status dialog can contain\n" . "more than one line, but that is\n" . "about all that can be told about\n" . "status dialogs I'm afraid :-)" ); sleep 3; $cui->nostatus; } } ] ); # ---------------------------------------------------------------------- # Dialog::Calendar # ---------------------------------------------------------------------- $w{14}->add( undef, 'Label', -text => "Curses::UI has a number of ready-to-use dialog windows.\n" . "The calendar dialog is one of them. Using this dialog\n" . "it is possible to select a date." ); $w{14}->add( undef, 'Label', -y => 7, -text => 'Date:' ); $w{14}->add( 'datelabel', 'Label', -width => 10, -y => 7, -x => 6, -text => 'none', ); $w{14}->add( undef, 'Buttonbox', -y => 7, -x => 17, -buttons => [ { -label => "< Set date >", -onpress => sub { my $label = shift()->parent->getobj('datelabel'); my $date = $label->get; print STDERR "$date\n"; $date = undef if $date eq 'none'; my $return = $cui->calendardialog(-date => $date); $label->text($return) if defined $return; } },{ -label => "< Clear date >", -onpress => sub { my $label = shift()->parent->getobj('datelabel'); $label->text('none'); } } ] ); # ---------------------------------------------------------------------- # Dialog::Question # ---------------------------------------------------------------------- $w{15}->add( undef, 'Label', -text => "Curses::UI has a number of ready-to-use dialog windows.\n" . "The question dialog is one of them. Using this dialog\n" . "it is possible to prompt the user to enter an answer.", ); $w{15}->add( undef, 'Buttonbox', -y => 7, -buttons => [ { -label => "< Example 1 >", -onpress => sub { my $button = shift; my $feeling = $button->root->question("How awesome are you?"); if ($feeling) { $button->root->dialog("You answered '$feeling'"); } else { $button->root->dialog("Question cancelled."); } } },{ -label => "< Example 2 >", -onpress => sub { my $button = shift; my $feeling = $button->root->question( -question => "How does coffee make you feel?", -title => 'Dialog::Question example', ); if ($feeling) { $button->root->dialog("You answered '$feeling'"); } else { $button->root->dialog("Question cancelled."); } } },{ -label => "< Example 3 >", -onpress => sub { my $button = shift; my $feeling = $button->root->question( -question => "How does coffee make you feel?", -title => 'Dialog::Question example', -answer => "Really good.", ); if ($feeling) { $button->root->dialog("You answered '$feeling'"); } else { $button->root->dialog("Question cancelled."); } } } ], ); # ---------------------------------------------------------------------- # Setup bindings and focus # ---------------------------------------------------------------------- # Bind <CTRL+Q> to quit. $cui->set_binding( sub{ exit }, "\cQ" ); # Bind <CTRL+X> to menubar. $cui->set_binding( sub{ shift()->root->focus('menu') }, "\cX" ); sub goto_next_demo() { $current_demo++; $current_demo = @screens if $current_demo > @screens; $w{$current_demo}->focus; } $cui->set_binding( \&goto_next_demo, "\cN" ); sub goto_prev_demo() { $current_demo--; $current_demo = 1 if $current_demo < 1; $w{$current_demo}->focus; } $cui->set_binding( \&goto_prev_demo, "\cP" ); $w{$current_demo}->focus; # ---------------------------------------------------------------------- # Get things rolling... # ---------------------------------------------------------------------- $cui->mainloop; ��������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/mouse_focustest�����������������������������������������������������������0000755�0001750�0000144�00000002130�11627564365�017266� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w use strict; use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; my $cui = new Curses::UI (-clear_on_exit => 1, -mouse_support => 1); my $sw = $cui->add( undef, 'Window', -y => -1, -height => 3, -width => -1, -border => 1, ); my $status = $sw->add( undef, 'Label', -width => -1, -padright => 8, -text => 'Status: program started... Use the mouse to shift focus' ); $sw->add( undef, 'Buttonbox', -buttons => [{ -label=>'< Quit >', -onpress => sub {exit(0)}, }], -width => 8, -buttonalignment => 'right', -x => -1, ); for my $nr (1..5) { $cui->add( undef, 'Window', -x => 12*$nr - 9, -y => 2*$nr - 1, -width => 20, -height => 10, -border => 1, -title => "window $nr", -onfocus => sub{ $status->text("Status: Focus to window $nr"); }, ); } $cui->set_binding(sub{exit}, "\cC", "\cQ"); if ($Curses::UI::ncurses_mouse) { $status->text($status->text() . " (mouse support enabled)"); } else { $status->text($status->text() . " (mouse support disabled)"); } $cui->mainloop; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/pop3_reader���������������������������������������������������������������0000755�0001750�0000144�00000015550�11627564365�016254� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w use strict; use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; use Curses; use Net::POP3; use Mail::Header; use Mail::Address; my $cui = new Curses::UI ( -clear_on_exit => 1 ); my $pop3 = undef; my $connection = undef; # We do not want STDERR to clutter our screen. open STDERR, ">/dev/null"; # ---------------------------------------------------------------------- # setup(): Setup the connection # ---------------------------------------------------------------------- sub check_connection($;) { my $buttons = shift; my $conwin = $buttons->parent; my $cui = $conwin->root; foreach my $key ('username','password','host','port') { my $obj = $conwin->getobj($key); my $value = $obj->get; $connection->{$key} = $value; # TODO: focus back to entry does not seem to # move the cursor with it. if ($value =~ /^\s*$/) { $cui->error("Missing value for $key field"); $obj->focus; return; } } return 1; } sub setup_connection() { my $conwin = $cui->add( 'connection_window', 'Window', -border => 1, -ipad => 2, -height => 15, -width => 60, -centered => 1, -title => "POP3 connection", ); $conwin->add( 'host_label', 'Label', -x => 0, -y => 0, -width => 13, -textalignment => 'right', -text => 'POP3 host :', ); $conwin->add( 'host', 'TextEntry', -x => 14, -y => 0, -text => 'pop', ); $conwin->add( 'port_label', 'Label', -x => 0, -y => 2, -width => 13, -textalignment => 'right', -text => 'POP3 port :', ); $conwin->add( 'port', 'TextEntry', -x => 14, -y => 2, -regexp => '/^\d*$/', -text => '110', ); $conwin->add( 'username_label', 'Label', -x => 0, -y => 4, -width => 13, -textalignment => 'right', -text => 'Username :', ); $conwin->add( 'username', 'TextEntry', -x => 14, -y => 4, -text => getpwuid($>), ); $conwin->add( 'password_label', 'Label', -x => 0, -y => 6, -width => 13, -textalignment => 'right', -text => 'Password :', ); $conwin->add( 'password', 'TextEntry', -x => 14, -y => 6, -password => '*', -text => '', )->focus; my $buttons = $conwin->add( 'buttons', 'Buttonbox', -x => 14, -y => 8, -buttons => [ { -label => '< Connect >', -onpress => sub { my $this = shift; if (check_connection($this)) { if (pop3_connect()) { $this->parent->loose_focus; } } }, }, { -label => '< Quit >', -onpress => sub {exit} }, ], ); $conwin->modalfocus; $cui->delete('connection_window') } # ---------------------------------------------------------------------- # pop3_connect(): Connect to the POP3 server and exit if it fails # ---------------------------------------------------------------------- sub pop3_connect() { $cui->progress( -message => "Connecting to the POP3 server...", -max => 4, -pos => 1, ); my $error = 0; $pop3 = Net::POP3->new( $connection->{host}, Port => $connection->{port}, Timeout => 0, ); if (not $pop3) { $error++; $cui->error("Could not connect to " ."$connection->{host}:$connection->{port}"); } $cui->setprogress(2, "Sending username..."); if (not $error and not defined $pop3->user($connection->{username})) { $error++; my $err = $pop3->message(); chomp $err; $cui->error("Sending USER failed:\n$err"); } $cui->setprogress(3, "Sending password..."); if (not $error and not defined $pop3->pass($connection->{password})) { $error++; my $err = $pop3->message(); chomp $err; $cui->error("Sending PASS failed:\n$err"); } if (not $error) { $cui->setprogress(4, "Connection successful!"); sleep 1; } $cui->noprogress; return !$error; } # ---------------------------------------------------------------------- # The inbox screen # ---------------------------------------------------------------------- sub build_inbox() { my $list = $pop3->list(); my @ids = sort {$a<=>$b} keys %$list; my $msg = "Retrieving headers"; $cui->progress( -max => scalar(@ids), -message => $msg, ); my @values = (); my %labels = (); my $progress_pos = 0; foreach my $n (@ids) { my $lines = $pop3->top($n, 0); my $header = new Mail::Header($lines); # Add value push @values, $n; # Add label my $subject = $header->get('Subject'); my $from = $header->get('From'); my $addr = new Mail::Address($from); my $name = substr($addr->name, 0, 15); $labels{$n} = sprintf("%4d", $n) . " | " . sprintf("%15s", $name) . " | " . $header->get('Subject'); $cui->setprogress( ++$progress_pos, $msg . ": message $progress_pos of " . scalar(@ids) ); } $cui->noprogress; my $listwin = $cui->add('list_window', 'Window'); my $ml = $listwin->add( 'message_list', 'Listbox', -values => \@values, -labels => \%labels, -vscrollbar => 1, -border => 1, -ipad => 1, -title => '<ENTER> view message <CTR+Q> Quit from program', ); $ml->set_binding(sub{exit(0)}, "\cC", "\cQ"); $ml->set_routine('option-select', \&view_message); } # ---------------------------------------------------------------------- # view_message(): callback routine for the inbox list # ---------------------------------------------------------------------- sub view_message() { my $this = shift; # Get the selected message id. $this->{-selected} = $this->{-ypos}; my $id = $this->get; $this->{-selected} = undef; # Retrieve the message from the POP3 server. $cui->status("Retrieving message $id from the POP3 server..."); my $lines = $pop3->get($id); unless (ref $lines) { # Maybe the connection went away. Reconnect and try again. $pop3->close; unless (pop3_connect()) { $cui->error("Fatal error: Could not reconnect\n" . "to the POP3 server."); exit(1); } $lines = $pop3->get($id); } unless (ref $lines) { $cui->error("Failed to retrieve message $id\n" ."from the POP3 server.\n" ."Even after reconnecting"); exit_program(); } $cui->nostatus; # Create the viewer window. my $viewwin = $cui->add('view_window', 'Window'); my $tv = $viewwin->add( 'textviewer', 'TextViewer', -text => join("", @$lines), -vscrollbar => 1, -wrapping => 1, -border => 1, -ipad => 1, -title => '<ENTER> return to inbox <CTRL+Q>: Quit from program', ); $viewwin->set_binding(sub{ shift()->loose_focus }, KEY_ENTER()); $viewwin->set_binding(sub{exit(0)}, "\cC", "\cQ"); $viewwin->modalfocus; $cui->delete('view_window'); $cui->draw; } # ---------------------------------------------------------------------- # Clean exit # ---------------------------------------------------------------------- END { $pop3->quit if defined $pop3 } # ---------------------------------------------------------------------- # The main program # ---------------------------------------------------------------------- setup_connection(); build_inbox(); $cui->mainloop; ��������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/editor��������������������������������������������������������������������0000755�0001750�0000144�00000012101�11627564365�015324� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # ---------------------------------------------------------------------- # Script: editor # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # e-mail: maurice@gitaar.net # ---------------------------------------------------------------------- use strict; use Curses; use Cwd; # Use the libraries from the distribution, instead of # system wide libraries. use FindBin; use lib "$FindBin::RealBin/../lib"; # Load an initial file if an argument given on the command line. # If the file can't be found, assume that this is a new file. my $text = ""; my $currentfile = shift; if (defined $currentfile and -f $currentfile) { open F, "<$currentfile" or die "Can't read $currentfile: $!\n"; while (<F>) { $text .= $_ } $currentfile = $currentfile; close F; } # We don't want STDERR output to clutter the screen. # # Hint: If you need STDERR, write it out to a file and put # a tail on that file to see the STDERR output. Example: #open STDERR, ">>/tmp/editor_errors.$$"; open STDERR, ">/dev/null"; # ---------------------------------------------------------------------- # Menu definition # ---------------------------------------------------------------------- my @menu = ( { -label => 'File', -submenu => [ { -label => 'Open file ^O', -value => \&open_dialog }, { -label => 'Save file ^S', -value => \&save_dialog }, { -label => 'Exit ^Q', -value => \&exit_dialog } ] }, { -label => 'Help', -submenu => [ { -label => 'About editor', -value => \&about_dialog } ] } ); # ---------------------------------------------------------------------- # Create widgets # ---------------------------------------------------------------------- # Create the root. Everything else will be built up from here. use Curses::UI; my $cui = new Curses::UI ( -clear_on_exit => 1 ); # Add the menu to the root. my $menu = $cui->add( 'menu','Menubar', -menu => \@menu, ); # Create the screen for the editor. my $screen = $cui->add( 'screen', 'Window', -padtop => 1, # leave space for the menu -border => 0, -ipad => 0, ); # We add the editor widget to this screen. my $editor = $screen->add( 'editor', 'TextEditor', -border => 1, -padtop => 0, -padbottom => 3, -showlines => 0, -sbborder => 0, -vscrollbar => 1, -hscrollbar => 1, -showhardreturns => 0, -wrapping => 0, # wrapping slows down the editor :-( -text => $text, ); # There is no need for the editor widget to loose focus, so # the "loose-focus" binding is disabled here. This also enables the # use of the "TAB" key in the editor, which is nice to have. $editor->clear_binding('loose-focus'); # Help information for the user. $screen->add( 'help', 'Label', -y => -2, -width => -1, -reverse => 1, -paddingspaces => 1, -text => " ^Q Quit from the program ^S save file" . " ^W toggle wrapping\n" . " ^X Open the menu ^O open file" . " ^R toggle hard returns viewing", ); # ---------------------------------------------------------------------- # Callback routines # ---------------------------------------------------------------------- sub open_dialog() { my $file = $cui->loadfilebrowser( -file => $currentfile, ); if (defined $file) { if (open F, "<$file") { my $text = ""; while (<F>) { $text .= $_ } close F; $editor->text($text); $editor->cursor_to_home; $currentfile = $file; } else { $cui->error(-message => "Can't read file \"$file\":\n$!"); } } } sub save_dialog() { my $file = $cui->savefilebrowser( -file => $currentfile, ); return unless defined $file; if (open F, ">$file") { print F $editor->text; if (close F) { $cui->dialog(-message => "File \"$file\"\nsuccessfully saved"); $currentfile = $file; } else { $cui->error(-message => "Error on closing file \"$file\":\n$!"); } } else { $cui->error(-message => "Can't write to $file:\n$!"); } } sub about_dialog() { $cui->dialog( -title => 'About editor', -message => "Program : Curses::UI Editor\n" . "Author : Maurice Makaay\n" . "\n" . "The sole purpose of this editor\n" . "is the demonstration of my perl\n" . "Curses::UI widget set." ); } sub exit_dialog() { my $return = $cui->dialog( -title => "Are you sure???", -buttons => ['yes', 'no'], -message => "Do you really want to quit?" ); exit(0) if $return; } # ---------------------------------------------------------------------- # The main loop of the program # ---------------------------------------------------------------------- $cui->set_binding(\&exit_dialog, "\cQ", "\cC"); $cui->set_binding(\&save_dialog, "\cS"); $cui->set_binding(\&open_dialog, "\cO"); $cui->set_binding(sub {shift()->getobj('menu')->focus}, "\cX", KEY_F(10)); $cui->set_binding(sub { my $cui = shift; $cui->layout; $cui->draw; }, "\cL"); # Bring the focus to the editor widget. $editor->focus; $cui->mainloop; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/demo-buttonbox������������������������������������������������������������0000755�0001750�0000144�00000001553�11627564365�017015� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # 2004 (c) by Marcus Thiesen (marcus@thiesen.org) # This file is a part of Curses::UI and might be distributed # under the same terms as perl itself. # Use the libraries from the distribution, instead of # system wide libraries. use FindBin; use lib "$FindBin::RealBin/../lib"; use strict; use Curses::UI; $Curses::UI::debug = 0; my $cui = new Curses::UI( -color_support => 1 ); my $win1 = $cui->add( 'win1', 'Window', -border => 1, -y => 1, -bfg => 'red', ); $win1->add("box1", "Buttonbox", -buttons => [ { -label => "< ADD >", }, { -label => "< FOO >" }] , ); $win1->add("box2", "Buttonbox", -y => 10, -vertical => 1, -buttons => [ { -label => "< ADD >", }, { -label => "< FOO >" }] , ); $cui->set_binding( sub {exit 0;}, "q"); $cui->mainloop; �����������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/hello_world���������������������������������������������������������������0000755�0001750�0000144�00000000261�11627564365�016354� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w use strict; use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; my $cui = new Curses::UI (-clear_on_exit => 1); $cui->dialog("Hello, world!"); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/demo-color����������������������������������������������������������������0000755�0001750�0000144�00000001566�11627564365�016113� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w use strict; use warnings; #use diagnostics; use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; my $cui = new Curses::UI(-color_support => 1, -clear_on_exit => 0); my $co = $Curses::UI::color_object; my @colors = $co->get_colors(); my @labels; my $mainw = $cui->add('screen', 'Window'); for my $i (0..$ENV{LINES} - 1) { my $label =$mainw->add("label$i",'Label', -fg => $colors[int rand @colors], -bg => $colors[int rand @colors], -text => " " x $i . "Curses::UI::Color", -paddingspaces => 1, -width => -1, -y => $i); push @labels, $label; } $cui->draw(); while (1) { my $nr = int rand @labels; $labels[$nr]->set_color_fg($colors[int rand @colors]); $labels[$nr]->set_color_bg($colors[int rand @colors]); $cui->draw(); } ������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/demo-add������������������������������������������������������������������0000755�0001750�0000144�00000003765�11627564365�015530� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # 2004 (c) by Marcus Thiesen (marcus@thiesen.org) # This file is a part of Curses::UI and might be distributed # under the same terms as perl itself. # Use the libraries from the distribution, instead of # system wide libraries. use FindBin; use lib "$FindBin::RealBin/../lib"; use strict; use Curses::UI; $Curses::UI::debug = 0; my $cui = new Curses::UI( -color_support => 1 ); my $win1 = $cui->add( 'win1', 'Window', -border => 1, -y => 1, -bfg => 'red', ); $win1->add("d1", "TextEntry", -border => 0, -fg => "green", -x => 2 , -y => 1 , -width => 5, -text => "A", -focusable => 0, -readonly => 1,); my $ent1 = $win1->add("ent1", "TextEntry", -border => 1, -bfg => "green", -x => 10 , -width => 10); $win1->add("d2", "TextEntry", -border => 0, -fg => "blue", -x => 2 , -y => 4 , -width => 5, -text => "B", -focusable => 0, -readonly => 1,); my $ent2 = $win1->add("ent2", "TextEntry", -border => 1, -bfg => "blue", -y => 3, -x => 10, -width => 10); $win1->add("d3", "TextEntry", -border => 0, -fg => "red", -x => 2 , -y => 11 , -width => 5, -text => "C", -focusable => 0, -readonly => 1,); my $ent3 = $win1->add("ent3", "TextEntry", -border => 1, -bfg => "red", -y => 10, -x => 10 , -width => 10, -readonly => 1, -focusable => 0, ) ; my $but1 = $win1->add("addbutton", "Buttonbox" , -buttons => [ { -label => "< ADD >", -onpress => \&add } ] , -y => 15, -x => 5 ); sub add { if (($ent1->get() =~ /[\d.]+/) && ($ent2->get() =~ /[\d.]+/)) { $ent3->text($ent1->get() + $ent2->get()); } else { $cui->error("You have to enter a number in A and B"); } } $cui->set_binding( sub {exit 0;}, "q"); $cui->mainloop; �����������Curses-UI-0.9609/examples/demo-cuml�����������������������������������������������������������������0000755�0001750�0000144�00000001531�11627564365�015725� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # Tutorial example # 2003 (c) by Marcus Thiesen (marcus@cpan.org) # This file is a part of Curses::UI and might be distributed # under the same terms as perl itself. # Use the libraries from the distribution, instead of # system wide libraries. use FindBin; use lib "$FindBin::RealBin/../lib"; use strict; use Curses::UI; my $cui = new Curses::UI( -color_support => 1 ); my $win1 = $cui->add( 'win1', 'Window', -border => 1, -y => 1, -bfg => 'red', ); my $listbox = $win1->add('lb', 'Listbox', -multi => 1, -htmltext => 1, -values => [ "<reverse>reverse text</reverse>", "<bold>bold text</bold>", "<underline>underlined text</underline>", "<blink>blinking text</blink>", "<dim>dim text</dim>", ], ); $cui->draw; sleep 5; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/demo-language�������������������������������������������������������������0000755�0001750�0000144�00000001667�11627564365�016562� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w use strict; use warnings; use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; use File::Spec; use File::Temp qw ( :POSIX ); my $debug = 0; my $fh = tmpfile(); open STDERR, ">&$fh"; if (@ARGV and $ARGV[0] eq '-d') { $debug = 1; } my $cui = new Curses::UI ( -clear_on_exit => 0, -debug => $debug, ); my $filename; foreach my $mod (keys %INC) { $filename = $INC{$mod} if ($mod =~ /UI\.pm/); } $filename =~ s/\.pm//gi; $filename = File::Spec->catfile($filename, "Language"); opendir DIR, "$filename" or die "Couldn't open language dir $filename: $!\n"; my @entries = grep /\.pm$/, sort readdir(DIR); map s/\.pm$//, @entries; $cui->dialog( "This demo will present all languages of Curses::UI to you\n" . join "\n", @entries); foreach my $entry (@entries) { my $lang = new Curses::UI::Language("$entry"); $cui->lang($lang); $cui->dialog("\u$entry"); $cui->savefilebrowser(); } �������������������������������������������������������������������������Curses-UI-0.9609/examples/color_editor��������������������������������������������������������������0000755�0001750�0000144�00000014314�11627564365�016532� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # ---------------------------------------------------------------------- # Script: editor # # (c) 2001-2002 by Maurice Makaay. All rights reserved. # This file is part of Curses::UI. Curses::UI is free software. # You can redistribute it and/or modify it under the same terms # as perl itself. # # e-mail: maurice@gitaar.net # # Color demo 2003 (c) by Marcus Thiesen # marcus@cpan.org # # ---------------------------------------------------------------------- use strict; use Curses; use Cwd; # Use the libraries from the distribution, instead of # system wide libraries. use FindBin; use lib "$FindBin::RealBin/../lib"; # Load an initial file if an argument given on the command line. # If the file can't be found, assume that this is a new file. my $text = ""; my $currentfile = shift; if (defined $currentfile and -f $currentfile) { open F, "<$currentfile" or die "Can't read $currentfile: $!\n"; while (<F>) { $text .= $_ } $currentfile = $currentfile; close F; } # We don't want STDERR output to clutter the screen. # # Hint: If you need STDERR, write it out to a file and put # a tail on that file to see the STDERR output. Example: #open STDERR, ">>/tmp/editor_errors.$$"; open STDERR, ">/dev/null"; # ---------------------------------------------------------------------- # Menu definition # ---------------------------------------------------------------------- my @menu = ( { -label => 'File', -submenu => [ { -label => 'Open file ^O', -value => \&open_dialog }, { -label => 'Save file ^S', -value => \&save_dialog }, { -label => 'Exit ^Q', -value => \&exit_dialog } ] }, { -label => 'Help', -submenu => [ { -label => 'About editor', -value => \&about_dialog } ] } ); # ---------------------------------------------------------------------- # Create widgets # ---------------------------------------------------------------------- # Create the root. Everything else will be built up from here. use Curses::UI; my $cui = new Curses::UI ( -clear_on_exit => 1, -color_support => 1 ); # Add the menu to the root. my $menu = $cui->add( 'menu','Menubar', -fg => "white", -bg => "blue", -menu => \@menu, ); # Create the screen for the editor. my $screen = $cui->add( 'screen', 'Window', -padtop => 1, # leave space for the menu -border => 0, -ipad => 0, ); # We add the editor widget to this screen. my $editor = $screen->add( 'editor', 'TextEditor', -border => 1, -bfg => "red", -bbg => "white", -sfg => "blue", -sbg => "white", -padtop => 0, -padbottom => 3, -showlines => 0, -sbborder => 0, -vscrollbar => 1, -hscrollbar => 1, -showhardreturns => 0, -wrapping => 0, # wrapping slows down the editor :-( -text => $text, -bg => "white", -fg => "red", ); # There is no need for the editor widget to loose focus, so # the "loose-focus" binding is disabled here. This also enables the # use of the "TAB" key in the editor, which is nice to have. $editor->clear_binding('loose-focus'); # Help information for the user. $screen->add( 'help', 'Label', -y => -2, -width => -1, -reverse => 1, -paddingspaces => 1, -fg => "blue", -bg => "white", -text => " ^Q Quit from the program ^S save file" . " ^W toggle wrapping\n" . " ^X Open the menu ^O open file" . " ^R toggle hard returns viewing", ); # ---------------------------------------------------------------------- # Callback routines # ---------------------------------------------------------------------- sub open_dialog() { my $file = $cui->loadfilebrowser( -file => $currentfile, -bg => "green", -fg => "white", -bbg => "green", -bfg => "white", -tbg => "green", -tfg => "white", ); if (defined $file) { if (open F, "<$file") { my $text = ""; while (<F>) { $text .= $_ } close F; $editor->text($text); $editor->cursor_to_home; $currentfile = $file; } else { $cui->error(-message => "Can't read file \"$file\":\n$!"); } } } sub save_dialog() { my $file = $cui->savefilebrowser( -file => $currentfile, -bg => "green", -fg => "white", -bbg => "green", -bfg => "white", -tbg => "green", -tfg => "white", ); return unless defined $file; if (open F, ">$file") { print F $editor->text; if (close F) { $cui->dialog(-message => "File \"$file\"\nsuccessfully saved"); $currentfile = $file; } else { $cui->error(-message => "Error on closing file \"$file\":\n$!"); } } else { $cui->error(-message => "Can't write to $file:\n$!"); } } sub about_dialog() { $cui->dialog( -title => 'About editor', -message => "Program : Curses::UI Editor\n" . "Author : Maurice Makaay\n" . " Marcus Thiesen\n" . "\n" . "The sole purpose of this editor\n" . "is the demonstration of the perl\n" . "Curses::UI widget set and the newly\n" . "developed color support.\n", -bg => "white", -fg => "red", -bbg => "white", -bfg => "red", -tbg => "white", -tfg => "red", ); } sub exit_dialog() { my $return = $cui->dialog( -title => "Are you sure???", -buttons => ['yes', 'no'], -message => "Do you really want to quit?", -tbg => "white", -tfg => "red", -bg => "white", -fg => "red", -bbg => "white", -bfg => "red", ); exit(0) if $return; } # ---------------------------------------------------------------------- # The main loop of the program # ---------------------------------------------------------------------- $cui->set_binding(\&exit_dialog, "\cQ", "\cC"); $cui->set_binding(\&save_dialog, "\cS"); $cui->set_binding(\&open_dialog, "\cO"); $cui->set_binding(sub {shift()->getobj('menu')->focus}, "\cX", KEY_F(10)); $cui->set_binding(sub { my $cui = shift; $cui->layout; $cui->draw; }, "\cL"); # Bring the focus to the editor widget. $editor->focus; $cui->mainloop; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/examples/demo-notebook�������������������������������������������������������������0000755�0001750�0000144�00000005062�11627564365�016610� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # $Id: demo-notebook,v 1.1 2004/10/22 16:37:30 mthies2s Exp $ use strict; use File::Temp qw( :POSIX ); use lib "../lib"; # make KEY_BTAB (shift-tab) working in XTerm # and also at the same time enable colors #$ENV{TERM} = "xterm-vt220" if ($ENV{TERM} eq 'xterm'); my $debug = 0; if (@ARGV and $ARGV[0] eq '-d') { $debug = 1; } else { # We do not want STDERR to clutter our screen. my $fh = tmpfile(); open STDERR, ">&fh"; } use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; # Create the root object and main window. my $cui = new Curses::UI ( -clear_on_exit => 1, -debug => $debug, ); $cui->set_binding( sub { exit(0); } , "\cQ"); my $main = $cui->add( undef, 'Window', -title => 'Main Window', ); $main->add( undef, 'Label', -y => $main->height - 1, -width => $main->width, -text => '<PageUp> / <PageDown> cycles through pages; <Ctrl>-Q exits', -textalignment => 'middle', -bold => 1, ); # Create notebook and a couple of pages. my $notebook = $main->add( undef, 'Notebook', -height => $main->height - 1, ); my @quotes = ( "Forsan et haec olim meminisse iuvabit.\n(And perhaps someday it will be pleasant to remember these things.)\n\n - Vergil", "Yankee, n: In Europe, an American.\nIn the Northern States of our Union, a New Englander.\nIn the Southern States the word is unknown. (See DAMYANK.)\n\n - Ambrose Bierce, \"The Devil's Dictionary\" 1911", "I must not fear. Fear is the mind-killer. Fear is the little-death that\nbrings total obliteration. I will face my fear. I will permit it to pass\nover me and through me. And when it has gone past I will turn the inner\neye to see its path. Where the fear has gone there will be nothing.\nOnly I will remain.\n\n - Frank Herbert, \"Dune\", 1965", "El amor es un camino que de repente aparece\ny de tanto caminarlo se te pierde.\n\n - Victor Jara, \"El Amor es un Camino\"", "Who knows for what we live, and struggle, and die? ...\nWise men write many books, in words too hard to understand.\nBut this, the purpose of our lives, the end of all our struggle,\nis beyond all human wisdom.\n\n - Alan Paton, \"Cry, The Beloved Country\", 1948", ); my @pages; for (my $i = 1; $i <= 5; ++$i) { $pages[$i] = $notebook->add_page("Page $i"); $pages[$i]->add( undef, 'TextViewer', -x => 1, -y => 5, -text => $quotes[$i-1], ); } $notebook->focus; # Let user play. $cui->mainloop; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/���������������������������������������������������������������������������������0000755�0001750�0000144�00000000000�11630214052�012515� 5����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/10texteditor.t�������������������������������������������������������������������0000644�0001750�0000144�00000001135�11627564364�015262� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use Test::More tests => 5; use FindBin; use lib "$FindBin::RealBin/fakelib"; require ("$FindBin::RealBin/lorem.pl"); $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { use_ok( "Curses::UI"); } close STDIN or warn $!; my $cui = new Curses::UI("-clear_on_exit" => 0, "-mouse_support" => 1); $cui->leave_curses(); isa_ok($cui, "Curses::UI"); my $mainw = $cui->add("testw","Window"); isa_ok($mainw, "Curses::UI::Window"); my $wid = $mainw->add("testwidget","TextEditor"); isa_ok($wid, "Curses::UI::TextEditor"); $wid->text($lorem); ok($wid->get() eq $lorem, "get and set"); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/03dialog_classes.t���������������������������������������������������������������0000644�0001750�0000144�00000000720�11627564364�016044� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use strict; use Test; BEGIN { plan tests => 8 } foreach my $class (qw( Curses::UI::Dialog::Basic Curses::UI::Dialog::Filebrowser Curses::UI::Dialog::Error Curses::UI::Dialog::Status Curses::UI::Dialog::Calendar Curses::UI::Dialog::Dirbrowser Curses::UI::Dialog::Progress Curses::UI::Dialog::Question )) { my $file = $class; $file =~ s|::|/|g; $file .= '.pm'; require $file; ok(1); } ������������������������������������������������Curses-UI-0.9609/t/12gpm_handler.t������������������������������������������������������������������0000644�0001750�0000144�00000001624�11627564364�015354� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use strict; use Test::More tests => 5; use FindBin; use lib "$FindBin::RealBin/fakelib"; $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { sub require { my $mod = shift; if ($mod ne "Curses::UI::Mousehandler::GPM") { return CORE::require $mod; } else { $@ = "Couldn't load module $mod (faked by test)"; $INC{$mod} = undef; die $@; } } use_ok( "Curses::UI"); } my $cui = new Curses::UI("-clear_on_exit" => 0); isa_ok($cui, "Curses::UI"); $cui->{-read_timeout} = 0; $cui->do_one_event(); #should not lead to errors pass("Without forced GPM support"); undef $cui; $Curses::UI::initialized = 0; $Curses::UI::gpm_mouse = 1; #force mouse $cui = new Curses::UI("-clear_on_exit" => 0); isa_ok($cui, "Curses::UI"); $cui->{-read_timeout} = 1; eval { $cui->do_one_event(); }; if ($@) { pass("Undefined routine is ok"); } else { fail("Should have failed"); } ������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/05pod.t��������������������������������������������������������������������������0000644�0001750�0000144�00000000760�11627564364�013660� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- # Testing Plain old Documentation for Curses::UI # 2004 (c) by Marcus Thiesen # marcus@cpan.org use strict; use FindBin; use File::Find; use Test::More; #use Test::Pod (tests => 45); eval "use Test::Pod (tests => 45)"; plan skip_all => "Test::Pod required for testing POD" if $@; sub wanted { if ($File::Find::name =~ /\.pm$/) { pod_file_ok( "$File::Find::name", "POD Documentation in $_" ); } } my $dir = "$FindBin::RealBin/../lib/Curses/"; find(\&wanted, ($dir)); ����������������Curses-UI-0.9609/t/99misc.t�������������������������������������������������������������������������0000644�0001750�0000144�00000000254�11627564364�014044� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Test::More tests => 2; $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { use_ok( "Curses::UI"); } ok (!$Curses::UI::debug, "Debugging flag"); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/02widget_classes.t���������������������������������������������������������������0000644�0001750�0000144�00000001121�11627564364�016063� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use strict; use Test; BEGIN { plan tests => 15 } foreach my $class (qw( Curses::UI::Checkbox Curses::UI::Calendar Curses::UI::Label Curses::UI::Menubar Curses::UI::Progressbar Curses::UI::PasswordEntry Curses::UI::Buttonbox Curses::UI::Listbox Curses::UI::Popupmenu Curses::UI::TextEditor Curses::UI::TextEntry Curses::UI::TextViewer Curses::UI::Window Curses::UI::Radiobuttonbox Curses::UI::Notebook )) { my $file = $class; $file =~ s|::|/|g; $file .= '.pm'; require $file; ok(1); } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/06ui.t���������������������������������������������������������������������������0000644�0001750�0000144�00000001261�11627564364�013511� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test::More tests => 8; use strict; use warnings; use FindBin; use lib "$FindBin::RealBin/fakelib"; $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { use_ok( "Curses::UI"); use_ok( "Curses::UI::Color");} my $cui = new Curses::UI("-clear_on_exit" => 0); $cui->leave_curses(); isa_ok($cui, "Curses::UI"); $cui->userdata("foo bar baz"); ok($cui->userdata eq "foo bar baz", "userdata"); ok($cui->clear_on_exit() == 0, "clear_on_exit()"); $cui->clear_on_exit(1); ok($cui->clear_on_exit() == 1, "clear_on_exit()"); $cui->clear_on_exit(0); my $color = new Curses::UI::Color; isa_ok($color, "Curses::UI::Color"); $cui->set_color($color); ok($cui->color() eq $color, "set_color"); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/11listbox.t����������������������������������������������������������������������0000644�0001750�0000144�00000001727�11627564364�014563� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use Test::More tests => 10; use strict; use FindBin; use lib "$FindBin::RealBin/fakelib"; $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { use_ok( "Curses::UI"); require ("$FindBin::RealBin/lorem.pl"); } my $c = 0; my $counter = sub { return $c++ }; my $cui = new Curses::UI("-clear_on_exit" => 0); $cui->leave_curses(); isa_ok($cui, "Curses::UI"); my $mainw = $cui->add("testw","Window"); isa_ok($mainw, "Curses::UI::Window"); my $wid = $mainw->add("testwidget","Listbox"); $wid->onChange($counter); $wid->focus; isa_ok($wid, "Curses::UI::Listbox"); $wid->values( \@lorem ); ok(! defined $wid->get(), "get()"); $wid->set_selection( 1, 4, 7, 99, 5 ); ok($wid->get() eq "consectetur","set_selection() get()"); $wid->set_selection( 3 ); ok($wid->get() eq "sit","set_selection() get()"); ok($wid->get_active_value() eq "Lorem", "get_active_value()"); $wid->clear_selection(); ok(! defined $wid->get(), "get()"); ok( &$counter == 5, "onChange event"); �����������������������������������������Curses-UI-0.9609/t/08common.t�����������������������������������������������������������������������0000644�0001750�0000144�00000001721�11627564364�014367� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test::More tests => 9; use strict; use FindBin; use lib "$FindBin::RealBin/fakelib"; $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { use_ok( "Curses::UI"); use_ok( "Curses::UI::Common"); } # initialize my $cui = new Curses::UI("-clear_on_exit" => 0); $cui->leave_curses(); isa_ok($cui, "Curses::UI"); # create window my $mainw = $cui->add("testw","Window"); isa_ok($mainw, "Curses::UI::Window"); # misc original tests ok($mainw->root eq $cui, "root()"); my $data = { KEY => "value", FOO => "bar" }; Curses::UI::Common::keys_to_lowercase($data); is ($data->{key}, 'value', "keys_to_lowercase 1"); is ($data->{foo}, 'bar', "keys_to_lowercase 2"); #-------------------------------------------------------------------- scrlength is (Curses::UI::Common::scrlength("foo bar"), length("foo bar"), "scrlength == 7"); isnt (Curses::UI::Common::scrlength("foo\tbar"), length("foo bar"), "scrlength > 7"); ## TODO: ## split_to_lines ## text_dimension ## wrap stuff �����������������������������������������������Curses-UI-0.9609/t/fakelib/�������������������������������������������������������������������������0000755�0001750�0000144�00000000000�11630214052�014112� 5����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/fakelib/Curses.pm����������������������������������������������������������������0000644�0001750�0000144�00000021762�11627564364�015750� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # This is a FAKE Curses.pm # Uses to test Curses::UI # 2003 (c) by Marcus Thiesen # marcus@cpan.org # with some stolen code from the original # Curses.pm package Curses; $VERSION = 1.06; use Carp; require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); sub new { my $pkg = shift; my ($nl, $nc, $by, $bx) = (@_,0,0,0,0); unless ($_initscr++) { initscr() } return newwin($nl, $nc, $by, $bx); } sub DESTROY { } sub printw { addstr(sprintf shift, @_) } $LINES = 25; $COLS = 80; $stdscr = $Curses; $curscr = $Curses; $COLORS = ""; $COLOR_PAIRS = ""; @EXPORT = qw( printw LINES $LINES COLS $COLS stdscr $stdscr curscr $curscr COLORS $COLORS COLOR_PAIRS $COLOR_PAIRS addch echochar addchstr addchnstr addstr addnstr attroff attron attrset standend standout attr_get attr_off attr_on attr_set chgat COLOR_PAIR PAIR_NUMBER beep flash bkgd bkgdset getbkgd border box hline vline erase clear clrtobot clrtoeol start_color init_pair init_color has_colors can_change_color color_content pair_content delch deleteln insdelln insertln getch ungetch has_key KEY_F getstr getnstr getyx getparyx getbegyx getmaxyx inch inchstr inchnstr initscr endwin isendwin newterm set_term delscreen cbreak nocbreak echo noecho halfdelay intrflush keypad meta nodelay notimeout raw noraw qiflush noqiflush timeout typeahead insch insstr insnstr instr innstr def_prog_mode def_shell_mode reset_prog_mode reset_shell_mode resetty savetty getsyx setsyx curs_set napms move clearok idlok idcok immedok leaveok setscrreg scrollok nl nonl overlay overwrite copywin newpad subpad prefresh pnoutrefresh pechochar refresh noutrefresh doupdate redrawwin redrawln scr_dump scr_restore scr_init scr_set scroll scrl slk_init slk_set slk_refresh slk_noutrefresh slk_label slk_clear slk_restore slk_touch slk_attron slk_attrset slk_attr slk_attroff slk_color baudrate erasechar has_ic has_il killchar longname termattrs termname touchwin touchline untouchwin touchln is_linetouched is_wintouched unctrl keyname filter use_env putwin getwin delay_output flushinp newwin delwin mvwin subwin derwin mvderwin dupwin syncup syncok cursyncup syncdown getmouse ungetmouse mousemask enclose mouse_trafo mouseinterval BUTTON_RELEASE BUTTON_PRESS BUTTON_CLICK BUTTON_DOUBLE_CLICK BUTTON_TRIPLE_CLICK BUTTON_RESERVED_EVENT use_default_colors assume_default_colors define_key keybound keyok resizeterm resize getmaxy getmaxx flusok getcap touchoverlap new_panel bottom_panel top_panel show_panel update_panels hide_panel panel_window replace_panel move_panel panel_hidden panel_above panel_below set_panel_userptr panel_userptr del_panel set_menu_fore menu_fore set_menu_back menu_back set_menu_grey menu_grey set_menu_pad menu_pad pos_menu_cursor menu_driver set_menu_format menu_format set_menu_items menu_items item_count set_menu_mark menu_mark new_menu free_menu menu_opts set_menu_opts menu_opts_on menu_opts_off set_menu_pattern menu_pattern post_menu unpost_menu set_menu_userptr menu_userptr set_menu_win menu_win set_menu_sub menu_sub scale_menu set_current_item current_item set_top_row top_row item_index item_name item_description new_item free_item set_item_opts item_opts_on item_opts_off item_opts item_userptr set_item_userptr set_item_value item_value item_visible menu_request_name menu_request_by_name set_menu_spacing menu_spacing pos_form_cursor data_ahead data_behind form_driver set_form_fields form_fields field_count move_field new_form free_form set_new_page new_page set_form_opts form_opts_on form_opts_off form_opts set_current_field current_field set_form_page form_page field_index post_form unpost_form set_form_userptr form_userptr set_form_win form_win set_form_sub form_sub scale_form set_field_fore field_fore set_field_back field_back set_field_pad field_pad set_field_buffer field_buffer set_field_status field_status set_max_field field_info dynamic_field_info set_field_just field_just new_field dup_field link_field free_field set_field_opts field_opts_on field_opts_off field_opts set_field_userptr field_userptr field_arg form_request_name form_request_by_name ERR OK ACS_BLOCK ACS_BOARD ACS_BTEE ACS_BULLET ACS_CKBOARD ACS_DARROW ACS_DEGREE ACS_DIAMOND ACS_HLINE ACS_LANTERN ACS_LARROW ACS_LLCORNER ACS_LRCORNER ACS_LTEE ACS_PLMINUS ACS_PLUS ACS_RARROW ACS_RTEE ACS_S1 ACS_S9 ACS_TTEE ACS_UARROW ACS_ULCORNER ACS_URCORNER ACS_VLINE A_ALTCHARSET A_ATTRIBUTES A_BLINK A_BOLD A_CHARTEXT A_COLOR A_DIM A_INVIS A_NORMAL A_PROTECT A_REVERSE A_STANDOUT A_UNDERLINE COLOR_BLACK COLOR_BLUE COLOR_CYAN COLOR_GREEN COLOR_MAGENTA COLOR_RED COLOR_WHITE COLOR_YELLOW KEY_A1 KEY_A3 KEY_B2 KEY_BACKSPACE KEY_BEG KEY_BREAK KEY_BTAB KEY_C1 KEY_C3 KEY_CANCEL KEY_CATAB KEY_CLEAR KEY_CLOSE KEY_COMMAND KEY_COPY KEY_CREATE KEY_CTAB KEY_DC KEY_DL KEY_DOWN KEY_EIC KEY_END KEY_ENTER KEY_EOL KEY_EOS KEY_EXIT KEY_F0 KEY_FIND KEY_HELP KEY_HOME KEY_IC KEY_IL KEY_LEFT KEY_LL KEY_MARK KEY_MAX KEY_MESSAGE KEY_MIN KEY_MOVE KEY_NEXT KEY_NPAGE KEY_OPEN KEY_OPTIONS KEY_PPAGE KEY_PREVIOUS KEY_PRINT KEY_REDO KEY_REFERENCE KEY_REFRESH KEY_REPLACE KEY_RESET KEY_RESTART KEY_RESUME KEY_RIGHT KEY_SAVE KEY_SBEG KEY_SCANCEL KEY_SCOMMAND KEY_SCOPY KEY_SCREATE KEY_SDC KEY_SDL KEY_SELECT KEY_SEND KEY_SEOL KEY_SEXIT KEY_SF KEY_SFIND KEY_SHELP KEY_SHOME KEY_SIC KEY_SLEFT KEY_SMESSAGE KEY_SMOVE KEY_SNEXT KEY_SOPTIONS KEY_SPREVIOUS KEY_SPRINT KEY_SR KEY_SREDO KEY_SREPLACE KEY_SRESET KEY_SRIGHT KEY_SRSUME KEY_SSAVE KEY_SSUSPEND KEY_STAB KEY_SUNDO KEY_SUSPEND KEY_UNDO KEY_UP KEY_MOUSE BUTTON1_RELEASED BUTTON1_PRESSED BUTTON1_CLICKED BUTTON1_DOUBLE_CLICKED BUTTON1_TRIPLE_CLICKED BUTTON1_RESERVED_EVENT BUTTON2_RELEASED BUTTON2_PRESSED BUTTON2_CLICKED BUTTON2_DOUBLE_CLICKED BUTTON2_TRIPLE_CLICKED BUTTON2_RESERVED_EVENT BUTTON3_RELEASED BUTTON3_PRESSED BUTTON3_CLICKED BUTTON3_DOUBLE_CLICKED BUTTON3_TRIPLE_CLICKED BUTTON3_RESERVED_EVENT BUTTON4_RELEASED BUTTON4_PRESSED BUTTON4_CLICKED BUTTON4_DOUBLE_CLICKED BUTTON4_TRIPLE_CLICKED BUTTON4_RESERVED_EVENT BUTTON_CTRL BUTTON_SHIFT BUTTON_ALT ALL_MOUSE_EVENTS REPORT_MOUSE_POSITION NCURSES_MOUSE_VERSION E_OK E_SYSTEM_ERROR E_BAD_ARGUMENT E_POSTED E_CONNECTED E_BAD_STATE E_NO_ROOM E_NOT_POSTED E_UNKNOWN_COMMAND E_NO_MATCH E_NOT_SELECTABLE E_NOT_CONNECTED E_REQUEST_DENIED E_INVALID_FIELD E_CURRENT REQ_LEFT_ITEM REQ_RIGHT_ITEM REQ_UP_ITEM REQ_DOWN_ITEM REQ_SCR_ULINE REQ_SCR_DLINE REQ_SCR_DPAGE REQ_SCR_UPAGE REQ_FIRST_ITEM REQ_LAST_ITEM REQ_NEXT_ITEM REQ_PREV_ITEM REQ_TOGGLE_ITEM REQ_CLEAR_PATTERN REQ_BACK_PATTERN REQ_NEXT_MATCH REQ_PREV_MATCH MIN_MENU_COMMAND MAX_MENU_COMMAND O_ONEVALUE O_SHOWDESC O_ROWMAJOR O_IGNORECASE O_SHOWMATCH O_NONCYCLIC O_SELECTABLE REQ_NEXT_PAGE REQ_PREV_PAGE REQ_FIRST_PAGE REQ_LAST_PAGE REQ_NEXT_FIELD REQ_PREV_FIELD REQ_FIRST_FIELD REQ_LAST_FIELD REQ_SNEXT_FIELD REQ_SPREV_FIELD REQ_SFIRST_FIELD REQ_SLAST_FIELD REQ_LEFT_FIELD REQ_RIGHT_FIELD REQ_UP_FIELD REQ_DOWN_FIELD REQ_NEXT_CHAR REQ_PREV_CHAR REQ_NEXT_LINE REQ_PREV_LINE REQ_NEXT_WORD REQ_PREV_WORD REQ_BEG_FIELD REQ_END_FIELD REQ_BEG_LINE REQ_END_LINE REQ_LEFT_CHAR REQ_RIGHT_CHAR REQ_UP_CHAR REQ_DOWN_CHAR REQ_NEW_LINE REQ_INS_CHAR REQ_INS_LINE REQ_DEL_CHAR REQ_DEL_PREV REQ_DEL_LINE REQ_DEL_WORD REQ_CLR_EOL REQ_CLR_EOF REQ_CLR_FIELD REQ_OVL_MODE REQ_INS_MODE REQ_SCR_FLINE REQ_SCR_BLINE REQ_SCR_FPAGE REQ_SCR_BPAGE REQ_SCR_FHPAGE REQ_SCR_BHPAGE REQ_SCR_FCHAR REQ_SCR_BCHAR REQ_SCR_HFLINE REQ_SCR_HBLINE REQ_SCR_HFHALF REQ_SCR_HBHALF REQ_VALIDATION REQ_NEXT_CHOICE REQ_PREV_CHOICE MIN_FORM_COMMAND MAX_FORM_COMMAND NO_JUSTIFICATION JUSTIFY_LEFT JUSTIFY_CENTER JUSTIFY_RIGHT O_VISIBLE O_ACTIVE O_PUBLIC O_EDIT O_WRAP O_BLANK O_AUTOSKIP O_NULLOK O_PASSOK O_STATIC O_NL_OVERLOAD O_BS_OVERLOAD ); sub newwin{ return bless {}, "Curses"; } sub derwin{ return newwin; } sub getbegxy{ $_[1] = 1; $_[2] = 2; } sub getbegyx{ $_[1] = 1; $_[2] = 2; } sub getmaxyx{ $_[1] = 24; $_[2] = 80; } sub getch{ # ok, I got a problem here ... mess with the internals my $badboy = caller(); no strict 'refs'; # print STDERR "getch called for $badboy\n"; *{$badboy . "::get_key"} = sub(;$) { $foo = rand 2; #there is a deep dispute in curses UI #about if get_key returns a string or #a number --- so make it random :-) return "-1" if $foo >= 1; }; return -1; } sub AUTOLOAD { my $N = $AUTOLOAD; $N =~ s/^.*:://; #print "Autoload: $N\n"; # export this? if (grep /$N/, @EXPORT) { # Mouse needs an extra handler (actually, it must return # something other than the other if ($N eq "KEY_MOUSE") { *{"Curses::$N"} = sub { return "no key mouse"; }; #cache++ return "no key mouse"; } *{"Curses::$N"} = sub { return -1; }; #cache++ return -1; } croak "Curses constant '$N' is not defined in the Curses::UI fakelib"; } 1; ��������������Curses-UI-0.9609/t/01base_classes.t�����������������������������������������������������������������0000644�0001750�0000144�00000000576�11627564364�015526� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use strict; use Test; use FindBin; use lib "$FindBin::RealBin/../lib"; BEGIN { plan tests => 6 } foreach my $class (qw( Curses::UI Curses::UI::Common Curses::UI::Container Curses::UI::Widget Curses::UI::Searchable Curses::UI::Color )) { my $file = $class; $file =~ s|::|/|g; $file .= '.pm'; require $file; ok(1); } ����������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/04language_classes.t�������������������������������������������������������������0000644�0001750�0000144�00000001044�11627564364�016371� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use strict; use Test::Simple tests => 15; use File::Spec; use FindBin; use lib "$FindBin::RealBin/../lib"; use Curses::UI; my $filename; foreach my $mod (keys %INC) { $filename = $INC{$mod} if ($mod =~ /UI\.pm/); } $filename =~ s/\.pm//gi; $filename = File::Spec->catfile($filename, "Language"); opendir DIR, "$filename" or die "Couldn't open language dir $filename: $!\n"; my @entries = grep /.pm$/, readdir(DIR); foreach my $file (@entries) { require "Curses/UI/Language/$file"; $file =~ s/\.pm//gi; ok(1,$file); } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/lorem.pl�������������������������������������������������������������������������0000644�0001750�0000144�00000001114�11627564364�014211� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ use vars qw( $lorem @lorem ); $lorem = "Lorem ipsum dolor sit amet, consectetur". " adipisicing elit, sed do eiusmod tempor". " incididunt ut labore et dolore magna aliqua.". " Ut enim ad minim veniam, quis nostrud ". "exercitation ullamco laboris nisi ut aliquip". " ex ea commodo consequat. Duis aute irure dolor". "in reprehenderit in voluptate velit esse cillum". " dolore eu fugiat nulla pariatur. Excepteur sint". " occaecat cupidatat non proident, sunt in culpa qui". " officia deserunt mollit anim id est laborum."; @lorem = split / /, $lorem; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/09label.t������������������������������������������������������������������������0000644�0001750�0000144�00000001025�11627564364�014154� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use Test::More tests => 5; use FindBin; use lib "$FindBin::RealBin/fakelib"; require ("$FindBin::RealBin/lorem.pl"); $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { use_ok( "Curses::UI"); } my $cui = new Curses::UI("-clear_on_exit" => 0); $cui->leave_curses(); isa_ok($cui, "Curses::UI"); my $mainw = $cui->add("testw","Window"); isa_ok($mainw, "Curses::UI::Window"); my $wid = $mainw->add("testwidget","Label"); isa_ok($wid, "Curses::UI::Label"); $wid->text($lorem); ok($wid->get() eq $lorem,"set and get"); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/07widget.t�����������������������������������������������������������������������0000644�0001750�0000144�00000001156�11627564364�014363� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# -*- perl -*- use strict; use Test::More tests => 6; use FindBin; use lib "$FindBin::RealBin/fakelib"; $ENV{LINES} = 25; $ENV{COLUMNS} = 80; BEGIN { use_ok( "Curses::UI"); } my $cui = new Curses::UI("-clear_on_exit" => 0); $cui->leave_curses(); isa_ok($cui, "Curses::UI"); my $mainw = $cui->add("testw","Window"); isa_ok($mainw, "Curses::UI::Window"); my $wid = $mainw->add("testwidget","Widget"); isa_ok($wid, "Curses::UI::Widget"); $wid->set_routine("foo", "bar"); $wid->set_binding("foo", sub { print 1; } ); ok($wid->parentwindow eq $mainw, "parentwindow()"); ok($wid->in_topwindow, "in_topwindow()"); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/t/13notebook.t���������������������������������������������������������������������0000644�0001750�0000144�00000007622�11627564364�014721� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test::More tests => 30; use strict; use warnings; use FindBin; use lib "$FindBin::RealBin/fakelib"; use Curses::UI; $ENV{LINES} = 25; $ENV{COLUMNS} = 80; # Tests 1: module load. BEGIN { $| = 1; # Ensure Term::ReadKey doesn't fail to get the screen size. $ENV{LINES} = 25; $ENV{COLUMNS} = 80; use_ok('Curses::UI::Notebook'); } my $debug = 0; my $cui = new Curses::UI ( -clear_on_exit => 0, -debug => $debug, ); $cui->leave_curses(); my $win = $cui->add(undef, 'Window'); exit unless $win; # Tests 2-4: notebook object creation. my $nb1 = $win->add(undef, 'Notebook'); isa_ok( $nb1, 'Curses::UI::Notebook'); ok( $nb1->{-border} == 1 && $nb1->{-sbborder} == 0 && $nb1->{-padleft} == 0 && $nb1->{-ipadleft} == 1, 'Initialization w/ defaults' ); ok(!$nb1->active_page, 'active_page(), w/o pages'); my $nb2 = $win->add( undef, 'Notebook', -border => 0, -sbborder => 1, -wraparound => 0, ); ok( $nb2->isa('Curses::UI::Notebook') && $nb2->{-border} == 0 && $nb2->{-sbborder} == 1 && $nb2->{-wraparound} == 0, 'Initialization w/ specific values' ); # Tests 5-11: page addition. for (my $i = 1; $i <= 3; $i++) { my $page = $nb1->add_page("Page $i"); ok( defined $page && $page->isa('Curses::UI::Window') && scalar(@{$nb1->{-pages}}) == $i, "add_page(), page $i, nb1" ); } # nb: with three pages, tab window uses 28 spaces (6/tab for labels, 2/tab # for padding, 1/tab for start border, and 1 for final border) before # adding this page. my $page = $nb1->add_page('=' x ($nb1->{-w} - 28 - 3 + 1)); ok(!$page, 'add_page(), overflow'); for (my $i = 1; $i <= 3; $i++) { my $page = $nb2->add_page("Page $i"); ok( defined $page && $page->isa('Curses::UI::Window') && scalar(@{$nb2->{-pages}}) == $i, "add_page(), page $i, nb2" ); } # Tests 12-17: page ordering and wraparound. ok($nb1->active_page eq 'Page 1', 'active_page()'); ok($nb1->first_page eq 'Page 1', 'first_page()'); ok($nb1->last_page eq 'Page 3', 'last_page()'); ok($nb1->prev_page eq 'Page 3', 'prev_page(), w/ wraparound'); ok($nb2->prev_page eq 'Page 1', 'prev_page(), w/o wraparound'); ok($nb1->next_page eq 'Page 2', 'next_page()'); # Tests 18-19: page movement. ok( $nb1->activate_page('Page 3') && $nb1->active_page eq 'Page 3', 'active_page(), nb1' ); ok( $nb2->activate_page('Page 3') && $nb2->active_page eq 'Page 3', 'active_page(), nb2' ); # Tests 20-21: wraparound (at end). ok($nb1->next_page eq 'Page 1', 'next_page(), w/ wraparound'); ok($nb2->next_page eq 'Page 3', 'next_page() w/o wraparound'); # Tests 22-24: page deletion. $nb1->delete_page('Page 1'); ok( $nb1->first_page eq 'Page 2' && scalar(@{$nb1->{-pages}}) == 2, 'delete_page()' ); # - deleting active page should make Page 3 active. $nb1->activate_page('Page 2'); $nb1->delete_page('Page 2'); ok( $nb1->active_page eq 'Page 3' && $nb1->next_page eq 'Page 3' && scalar(@{$nb1->{-pages}}) == 1, 'delete_page(), active page' ); $nb1->delete_page('Page 3'); ok( !$nb1->active_page && scalar(@{$nb1->{-pages}}) == 0, 'delete_page(), final page' ); my ($activated_widget,$activated_name) ; my ($deleted_widget,$deleted_name) ; my $ac_sub = sub { ($activated_widget,$activated_name) = @_ ;} ; my $del_sub = sub { ($deleted_widget,$deleted_name) = @_ ;} ; # create page with activation and deletion call-back my $cbpage = $nb1->add_page("CB Page", -on_activate => $ac_sub, -on_delete => $del_sub ); ok($cbpage, "Created page with callback") ; $nb1->activate_page('CB Page'); is($activated_widget, $nb1, "activate callback called (widget ok)" ); is($activated_name, 'CB Page', "activate callback called (name ok)"); $nb1->delete_page('CB Page') ; is($deleted_widget, $nb1, "delete callback called (widget ok)" ); is($deleted_name, 'CB Page', "delete callback called (name ok)"); ��������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/CREDITS����������������������������������������������������������������������������0000644�0001750�0000144�00000003472�11627564365�013325� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������This file mentions persons that contributed to Curses::UI: Credits: ======= Robert De Leo : for contributing Dirbrowser and other valuable input Vlad Tepes : for contributing the norwegian translation and other valuable input Maurice Makaay : for designing and writing Curses::UI Ralf S. Engelschall : for sending valuable patches and giving good input. Luke Closs : patch maniac George Theall : Notebook Widget Marcus Theisen : First maintainer of Curses::UI Russ Allbery : for many patches and fixes Original Credits: ================= As the original code is by Maurice Makaay, these are his credits: Esther Bronk : (my girl) For being so patient while I was harassing her about the beauty of curses based user interfaces and for providing me the initial idea for Curses::UI (so basically it was her own fault :-). InterNLnet : (my employer) For the enthusiasm and support that I got from my colleagues and for sponsoring this project (I got to play hooky :-) See: http://www.internl.net/ William Setzer : Author of the Perl5 Curses extension, the module on which Curses::UI is built. Nick Slussar : For criticizing my software and for bringing up new ideas. Marcus Thiesen : For taking over the development of Curses::UI Raul Dias : For putting effort into Curses::UI and submitting multiple patches. Language Credits: =============== Nick Slussar : Russian translation Valentina Portolan : Italian translation Andrzej Kukula : Polish translation Albrecht Kleine : German translation Sebastian Desreux : French translation Raul Dias : Portuguese translation Vlad Tepes : Norwegian translation Marek Grac : Slovak translation Takatoshi Kitano : Japanese translation������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/README�����������������������������������������������������������������������������0000644�0001750�0000144�00000002673�11627564365�013167� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ _ ___ / ._ _ _ _ o o | | | \_ |_| | _> (/_ _> o o |_| _|_ A curses based user interface framework in perl What is Curses::UI? ------------------- A UI framework based on the curses library. Curses::UI contains several widgets which can be used to build a user interface: - Buttonbox - Calendar - Checkbox - Container (container base element) - Label - Listbox - Menubar - PasswordEntry - Popupmenu (a.k.a. pulldown- or dropdown menu) - Progressbar - Radiobuttonbox - Texteditor (has features like word wrapping and undo) - Textentry - Textviewer - Widget (widget base element) - Window There are also prefabricated dialog windows available: - Basic dialog window - Error dialog window - Filebrowser - Status window - Progress window - Calendar dialog window Localization ------------ Curses::UI can easily be configured to use a specific language. If you want a language that is not yet supported, please let me know. If you want to translate the needed strings, I'll add the language to the distribution. Currently the following languages are supported: - English - Dutch - German - Russian - Italian - Polish - Portuguese - Norwegian - Slovak Examples -------- Examples are in the distribution's "examples" directory. You do not have to install this distribution to test these examples. More Information ---------------- Please see 'perldoc ./lib/Curses/UI.pm' for more information. ���������������������������������������������������������������������Curses-UI-0.9609/META.yml���������������������������������������������������������������������������0000644�0001750�0000144�00000001055�11630214034�013524� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������--- abstract: 'A curses based OO user interface framework' author: - 'Shawn Boyette C<< <mdxi@cpan.org> >>' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.01' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Curses-UI no_index: directory: - examples - inc - t requires: Curses: 0 Term::ReadKey: 0 resources: license: http://dev.perl.org/licenses/ version: 0.9609 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/INSTALL����������������������������������������������������������������������������0000644�0001750�0000144�00000000614�11627564365�013331� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Curses::UI installation: ======================== Curses::UI depends on the Curses and Term::ReadKey packages. The installer will volunteer to take care of this for you via the CPAN, but you may wish to handle it through your package manager. Installation is the usual: > perl Makefile.PL > make > make test > # Optionally, "./example/demo-widgets" for an interactive test > sudo make install ��������������������������������������������������������������������������������������������������������������������Curses-UI-0.9609/Makefile.PL������������������������������������������������������������������������0000644�0001750�0000144�00000000515�11627564365�014252� 0����������������������������������������������������������������������������������������������������ustar �mdxi����������������������������users������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Load the Module::Install bundled in ./inc/ use inc::Module::Install; # Define metadata name 'Curses-UI'; all_from 'lib/Curses/UI.pm'; # Specific dependencies requires 'Curses' => 0; requires 'Term::ReadKey' => 0; no_index 'directory' => 'examples'; auto_install; WriteAll; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������