1package Term::Choose; 2 3use warnings; 4use strict; 5use 5.10.0; 6 7our $VERSION = '1.745'; 8use Exporter 'import'; 9our @EXPORT_OK = qw( choose ); 10 11use Carp qw( croak carp ); 12 13use Term::Choose::Constants qw( :all ); 14use Term::Choose::LineFold qw( line_fold print_columns cut_to_printwidth ); 15use Term::Choose::Screen qw( :all ); 16use Term::Choose::ValidateOptions qw( validate_options ); 17 18my $Plugin; 19 20BEGIN { 21 if ( $^O eq 'MSWin32' ) { 22 require Win32::Console::ANSI; 23 require Term::Choose::Win32; 24 $Plugin = 'Term::Choose::Win32'; 25 } 26 else { 27 require Term::Choose::Linux; 28 $Plugin = 'Term::Choose::Linux'; 29 } 30} 31 32 33sub new { 34 my $class = shift; 35 my ( $opt ) = @_; 36 croak "new: called with " . @_ . " arguments - 0 or 1 arguments expected" if @_ > 1; 37 my $instance_defaults = _defaults(); 38 if ( defined $opt ) { 39 croak "new: the (optional) argument must be a HASH reference" if ref $opt ne 'HASH'; 40 validate_options( _valid_options(), $opt, 'new' ); 41 for my $key ( keys %$opt ) { 42 $instance_defaults->{$key} = $opt->{$key} if defined $opt->{$key}; 43 } 44 } 45 my $self = bless $instance_defaults, $class; 46 $self->{backup_instance_defaults} = { %$instance_defaults }; 47 $self->{plugin} = $Plugin->new(); 48 return $self; 49} 50 51 52sub _valid_options { 53 return { 54 beep => '[ 0 1 ]', 55 clear_screen => '[ 0 1 ]', 56 codepage_mapping => '[ 0 1 ]', 57 hide_cursor => '[ 0 1 ]', 58 index => '[ 0 1 ]', 59 mouse => '[ 0 1 ]', 60 order => '[ 0 1 ]', 61 alignment => '[ 0 1 2 ]', 62 color => '[ 0 1 2 ]', 63 include_highlighted => '[ 0 1 2 ]', 64 page => '[ 0 1 2 ]', 65 search => '[ 0 1 2 ]', 66 layout => '[ 0 1 2 3 ]', # '[ 0 1 2 ]' 67 keep => '[ 1-9 ][ 0-9 ]*', 68 ll => '[ 1-9 ][ 0-9 ]*', 69 max_cols => '[ 1-9 ][ 0-9 ]*', 70 max_height => '[ 1-9 ][ 0-9 ]*', 71 max_width => '[ 1-9 ][ 0-9 ]*', 72 default => '[ 0-9 ]+', 73 pad => '[ 0-9 ]+', 74 mark => 'Array_Int', 75 meta_items => 'Array_Int', 76 no_spacebar => 'Array_Int', 77 tabs_info => 'Array_Int', 78 tabs_prompt => 'Array_Int', 79 skip_items => 'Regexp', 80 empty => 'Str', 81 footer => 'Str', 82 info => 'Str', 83 prompt => 'Str', 84 undef => 'Str', 85 busy_string => 'Str', 86 }; 87}; 88 89 90sub _defaults { 91 return { 92 alignment => 0, 93 beep => 0, 94 clear_screen => 0, 95 codepage_mapping => 0, 96 color => 0, 97 #default => undef, 98 empty => '<empty>', 99 #footer => undef, 100 hide_cursor => 1, 101 include_highlighted => 0, 102 index => 0, 103 info => '', 104 keep => 5, 105 layout => 1, 106 #ll => undef, 107 #mark => undef, 108 #max_cols => undef, 109 #max_height => undef, 110 #max_width => undef, 111 mouse => 0, 112 #meta_items => undef, 113 #no_spacebar => undef, 114 order => 1, 115 pad => 2, 116 page => 1, 117 #prompt => undef, 118 search => 1, 119 #skip_items => undef, 120 #tabs_info => undef, 121 #tabs_prompt => undef, 122 undef => '<undef>', 123 #busy_string => undef, 124 }; 125} 126 127 128sub __copy_orig_list { 129 my ( $self, $orig_list_ref ) = @_; 130 if ( $self->{ll} ) { 131 $self->{list} = $orig_list_ref; 132 } 133 else { 134 $self->{list} = [ @$orig_list_ref ]; 135 if ( $self->{color} ) { 136 $self->{orig_list} = $orig_list_ref; 137 } 138 for ( @{$self->{list}} ) { 139 if ( ! $_ ) { 140 $_ = $self->{undef} if ! defined $_; 141 $_ = $self->{empty} if ! length $_; 142 } 143 if ( $self->{color} ) { 144 s/\x{feff}//g; 145 s/\e\[[\d;]*m/\x{feff}/g; 146 } 147 s/\t/ /g; 148 s/\v+/\ \ /g; 149 # \p{Cn} might not be up to date and remove assigned codepoints 150 # therefore only \p{Noncharacter_Code_Point} 151 s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]//g; 152 } 153 } 154} 155 156 157sub __length_list_elements { 158 my ( $self ) = @_; 159 my $list = $self->{list}; 160 if ( $self->{ll} ) { 161 $self->{col_width} = $self->{ll}; 162 } 163 else { 164 my $length_elements = []; 165 my $longest = 0; 166 for my $i ( 0 .. $#$list ) { 167 $length_elements->[$i] = print_columns( $list->[$i] ); 168 $longest = $length_elements->[$i] if $length_elements->[$i] > $longest; 169 } 170 $self->{width_elements} = $length_elements; 171 $self->{col_width} = $longest; 172 } 173} 174 175 176sub __init_term { 177 my ( $self ) = @_; 178 my $config = { 179 mode => 'ultra-raw', 180 mouse => $self->{mouse}, 181 hide_cursor => $self->{hide_cursor}, 182 }; 183 $self->{mouse} = $self->{plugin}->__set_mode( $config ); 184} 185 186 187sub __reset_term { 188 my ( $self, $clear_choose ) = @_; 189 if ( defined $self->{plugin} ) { 190 $self->{plugin}->__reset_mode( { mouse => $self->{mouse}, hide_cursor => $self->{hide_cursor} } ); 191 } 192 if ( $clear_choose ) { 193 my $up = $self->{i_row} + $self->{count_prompt_lines}; 194 print up( $up ) if $up; 195 print "\r" . clear_to_end_of_screen(); 196 } 197 if ( exists $self->{backup_instance_defaults} ) { # backup_instance_defaults exists if ObjectOriented 198 my $instance_defaults = $self->{backup_instance_defaults}; 199 for my $key ( keys %$self ) { 200 if ( $key eq 'plugin' || $key eq 'backup_instance_defaults' ) { 201 next; 202 } 203 elsif ( exists $instance_defaults->{$key} ) { 204 $self->{$key} = $instance_defaults->{$key}; 205 } 206 else { 207 delete $self->{$key}; 208 } 209 } 210 } 211} 212 213 214sub __get_key { 215 my ( $self ) = @_; 216 my $key; 217 if ( defined $self->{skip_items} ) { 218 my $idx = $self->{rc2idx}[$self->{pos}[ROW]][$self->{pos}[COL]]; 219 if ( $self->{list}[$idx] =~ $self->{skip_items} ) { 220 $key = $self->Term::Choose::Opt::SkipItems::__key_skipped(); 221 } 222 } 223 if ( ! defined $key ) { 224 $key = $self->{plugin}->__get_key_OS( $self->{mouse} ); 225 } 226 return $key if ref $key ne 'ARRAY'; 227 return $self->Term::Choose::Opt::Mouse::__mouse_info_to_key( @$key ); 228} 229 230 231sub __modify_options { 232 my ( $self ) = @_; 233 ############################## remove this with the next release 234 if ( $self->{layout} == 3 ) { 235 my @caller = caller( 2 ); 236 print "@caller[1,2]\n"; 237 print "Term::Choose::choose\n"; 238 print "Option 'layout': 3 is not a valid value.\n"; 239 print "Press ENTER to continue:"; 240 my $dummy = <>; 241 $self->{layout} = 2; 242 } 243 ############################## 244 if ( defined $self->{max_cols} && $self->{max_cols} == 1 ) { 245 $self->{layout} = 2; 246 } 247 if ( length $self->{footer} && $self->{page} != 2 ) { 248 $self->{page} = 2; 249 } 250 if ( $self->{page} == 2 && ! $self->{clear_screen} ) { 251 $self->{clear_screen} = 1; 252 } 253 if ( $self->{max_cols} && $self->{layout} != 0 && $self->{layout} != 2 ) { ## 254 $self->{layout} = 0; 255 } 256 if ( ! defined $self->{prompt} ) { 257 $self->{prompt} = defined $self->{wantarray} ? 'Your choice:' : 'Close with ENTER'; 258 } 259} 260 261 262sub choose { 263 if ( ref $_[0] ne __PACKAGE__ ) { 264 my $ob = __PACKAGE__->new(); 265 delete $ob->{backup_instance_defaults}; 266 return $ob->__choose( @_ ); 267 } 268 my $self = shift; 269 return $self->__choose( @_ ); 270} 271 272sub __choose { 273 my $self = shift; 274 my ( $orig_list_ref, $opt ) = @_; 275 croak "choose: called with " . @_ . " arguments - 1 or 2 arguments expected" if @_ < 1 || @_ > 2; 276 croak "choose: the first argument must be an ARRAY reference" if ref $orig_list_ref ne 'ARRAY'; 277 if ( defined $opt ) { 278 croak "choose: the (optional) second argument must be a HASH reference" if ref $opt ne 'HASH'; 279 validate_options( _valid_options(), $opt, 'choose' ); 280 for my $key ( keys %$opt ) { 281 $self->{$key} = $opt->{$key} if defined $opt->{$key}; 282 } 283 } 284 if ( ! @$orig_list_ref ) { 285 return; 286 } 287 local $\ = undef; 288 local $, = undef; 289 local $| = 1; 290 if ( defined $self->{busy_string} ) { 291 print "\r" . clear_to_end_of_line(); 292 print $self->{busy_string}; 293 } 294 $self->{wantarray} = wantarray; 295 $self->__modify_options(); 296 if ( $self->{mouse} ) { 297 require Term::Choose::Opt::Mouse; 298 } 299 if ( $^O eq "MSWin32" ) { 300 print $opt->{codepage_mapping} ? "\e(K" : "\e(U"; 301 } 302 $self->__copy_orig_list( $orig_list_ref ); 303 $self->__length_list_elements(); 304 if ( defined $self->{skip_items} ) { 305 require Term::Choose::Opt::SkipItems; 306 $self->Term::Choose::Opt::SkipItems::__prepare_default(); 307 } 308 if ( exists $ENV{TC_RESET_AUTO_UP} ) { 309 $ENV{TC_RESET_AUTO_UP} = 0; 310 } 311 local $SIG{INT} = sub { 312 $self->__reset_term(); 313 exit; 314 }; 315 $self->__init_term(); 316 ( $self->{term_width}, $self->{term_height} ) = get_term_size(); 317 $self->__wr_first_screen(); 318 my $fast_page = 10; 319 if ( $self->{pp_count} > 10_000 ) { 320 $fast_page = 20; 321 } 322 my $saved_pos; 323 324 GET_KEY: while ( 1 ) { 325 my $key = $self->__get_key(); 326 if ( ! defined $key ) { 327 $self->__reset_term( 1 ); 328 carp "EOT: $!"; 329 return; 330 } 331 $self->{pressed_key} = $key; 332 my ( $new_width, $new_height ) = get_term_size(); 333 if ( $new_width != $self->{term_width} || $new_height != $self->{term_height} ) { 334 if ( $self->{ll} ) { 335 return -1; 336 } 337 ( $self->{term_width}, $self->{term_height} ) = ( $new_width, $new_height ); 338 $self->__copy_orig_list( $orig_list_ref ); 339 $self->{default} = $self->{rc2idx}[$self->{pos}[ROW]][$self->{pos}[COL]]; 340 if ( $self->{wantarray} && @{$self->{marked}} ) { 341 $self->{mark} = $self->__marked_rc2idx(); 342 } 343 my $up = $self->{i_row} + $self->{count_prompt_lines}; 344 print up( $up ) if $up; 345 print "\r" . clear_to_end_of_screen(); 346 $self->__wr_first_screen(); 347 next GET_KEY; 348 } 349 next GET_KEY if $key == NEXT_get_key; 350 next GET_KEY if $key == KEY_Tilde; 351 if ( exists $ENV{TC_RESET_AUTO_UP} ) { 352 if ( $key != LINE_FEED && $key != CARRIAGE_RETURN ) { 353 $ENV{TC_RESET_AUTO_UP} = 1; 354 } 355 } 356 my $page_step = 1; 357 if ( $key == VK_INSERT ) { 358 $page_step = $fast_page if $self->{first_page_row} - $fast_page * $self->{avail_height} >= 0; 359 $key = VK_PAGE_UP; 360 } 361 elsif ( $key == VK_DELETE ) { 362 $page_step = $fast_page if $self->{last_page_row} + $fast_page * $self->{avail_height} <= $#{$self->{rc2idx}}; 363 $key = VK_PAGE_DOWN; 364 } 365 if ( $saved_pos && $key != VK_PAGE_UP && $key != CONTROL_B && $key != VK_PAGE_DOWN && $key != CONTROL_F ) { 366 $saved_pos = undef; 367 } 368 # $self->{rc2idx} holds the new list (AoA) formatted in "__list_idx2rc" appropriate to the chosen layout. 369 # $self->{rc2idx} does not hold the values directly but the respective list indexes from the original list. 370 # If the original list would be ( 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h' ) and the new formatted list should be 371 # a d g 372 # b e h 373 # c f 374 # then the $self->{rc2idx} would look like this 375 # 0 3 6 376 # 1 4 7 377 # 2 5 378 # So e.g. the second value in the second row of the new list would be $self->{list}[ $self->{rc2idx}[1][1] ]. 379 # On the other hand the index of the last row of the new list would be $#{$self->{rc2idx}} 380 # or the index of the last column in the first row would be $#{$self->{rc2idx}[0]}. 381 382 if ( $key == VK_DOWN || $key == KEY_j ) { 383 if ( ! $self->{rc2idx}[$self->{pos}[ROW]+1] 384 || ! $self->{rc2idx}[$self->{pos}[ROW]+1][$self->{pos}[COL]] 385 ) { 386 $self->__beep(); 387 } 388 else { 389 $self->{pos}[ROW]++; 390 if ( $self->{pos}[ROW] <= $self->{last_page_row} ) { 391 $self->__wr_cell( $self->{pos}[ROW] - 1, $self->{pos}[COL] ); 392 $self->__wr_cell( $self->{pos}[ROW] , $self->{pos}[COL] ); 393 } 394 else { 395 $self->{first_page_row} = $self->{last_page_row} + 1; 396 $self->{last_page_row} = $self->{last_page_row} + $self->{avail_height}; 397 $self->{last_page_row} = $#{$self->{rc2idx}} if $self->{last_page_row} > $#{$self->{rc2idx}}; 398 $self->__wr_screen(); 399 } 400 } 401 } 402 elsif ( $key == VK_UP || $key == KEY_k ) { 403 if ( $self->{pos}[ROW] == 0 ) { 404 $self->__beep(); 405 } 406 else { 407 $self->{pos}[ROW]--; 408 if ( $self->{pos}[ROW] >= $self->{first_page_row} ) { 409 $self->__wr_cell( $self->{pos}[ROW] + 1, $self->{pos}[COL] ); 410 $self->__wr_cell( $self->{pos}[ROW] , $self->{pos}[COL] ); 411 } 412 else { 413 $self->{last_page_row} = $self->{first_page_row} - 1; 414 $self->{first_page_row} = $self->{first_page_row} - $self->{avail_height}; 415 $self->{first_page_row} = 0 if $self->{first_page_row} < 0; 416 $self->__wr_screen(); 417 } 418 } 419 } 420 elsif ( $key == KEY_TAB || $key == CONTROL_I ) { # KEY_TAB == CONTROL_I 421 if ( $self->{pos}[ROW] == $#{$self->{rc2idx}} 422 && $self->{pos}[COL] == $#{$self->{rc2idx}[$self->{pos}[ROW]]} 423 ) { 424 $self->__beep(); 425 } 426 else { 427 if ( $self->{pos}[COL] < $#{$self->{rc2idx}[$self->{pos}[ROW]]} ) { 428 $self->{pos}[COL]++; 429 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] - 1 ); 430 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] ); 431 } 432 else { 433 $self->{pos}[ROW]++; 434 if ( $self->{pos}[ROW] <= $self->{last_page_row} ) { 435 $self->{pos}[COL] = 0; 436 $self->__wr_cell( $self->{pos}[ROW] - 1, $#{$self->{rc2idx}[$self->{pos}[ROW] - 1]} ); 437 $self->__wr_cell( $self->{pos}[ROW] , $self->{pos}[COL] ); 438 } 439 else { 440 $self->{first_page_row} = $self->{last_page_row} + 1; 441 $self->{last_page_row} = $self->{last_page_row} + $self->{avail_height}; 442 $self->{last_page_row} = $#{$self->{rc2idx}} if $self->{last_page_row} > $#{$self->{rc2idx}}; 443 $self->{pos}[COL] = 0; 444 $self->__wr_screen(); 445 } 446 } 447 } 448 } 449 elsif ( $key == KEY_BSPACE || $key == KEY_BTAB || $key == CONTROL_H ) { # KEY_BTAB == CONTROL_H 450 if ( $self->{pos}[COL] == 0 && $self->{pos}[ROW] == 0 ) { 451 $self->__beep(); 452 } 453 else { 454 if ( $self->{pos}[COL] > 0 ) { 455 $self->{pos}[COL]--; 456 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] + 1 ); 457 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] ); 458 } 459 else { 460 $self->{pos}[ROW]--; 461 if ( $self->{pos}[ROW] >= $self->{first_page_row} ) { 462 $self->{pos}[COL] = $#{$self->{rc2idx}[$self->{pos}[ROW]]}; 463 $self->__wr_cell( $self->{pos}[ROW] + 1, 0 ); 464 $self->__wr_cell( $self->{pos}[ROW] , $self->{pos}[COL] ); 465 } 466 else { 467 $self->{last_page_row} = $self->{first_page_row} - 1; 468 $self->{first_page_row} = $self->{first_page_row} - $self->{avail_height}; 469 $self->{first_page_row} = 0 if $self->{first_page_row} < 0; 470 $self->{pos}[COL] = $#{$self->{rc2idx}[$self->{pos}[ROW]]}; 471 $self->__wr_screen(); 472 } 473 } 474 } 475 } 476 elsif ( $key == VK_RIGHT || $key == KEY_l ) { 477 if ( $self->{pos}[COL] == $#{$self->{rc2idx}[$self->{pos}[ROW]]} ) { 478 $self->__beep(); 479 } 480 else { 481 $self->{pos}[COL]++; 482 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] - 1 ); 483 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] ); 484 } 485 } 486 elsif ( $key == VK_LEFT || $key == KEY_h ) { 487 if ( $self->{pos}[COL] == 0 ) { 488 $self->__beep(); 489 } 490 else { 491 $self->{pos}[COL]--; 492 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] + 1 ); 493 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] ); 494 } 495 } 496 elsif ( $key == VK_PAGE_UP || $key == CONTROL_P ) { 497 if ( $self->{first_page_row} <= 0 ) { 498 $self->__beep(); 499 } 500 else { 501 $self->{first_page_row} = $self->{avail_height} * ( int( $self->{pos}[ROW] / $self->{avail_height} ) - $page_step ); 502 $self->{last_page_row} = $self->{first_page_row} + $self->{avail_height} - 1; 503 if ( $saved_pos ) { 504 $self->{pos}[ROW] = $saved_pos->[ROW] + $self->{first_page_row}; 505 $self->{pos}[COL] = $saved_pos->[COL]; 506 $saved_pos = undef; 507 } 508 else { 509 $self->{pos}[ROW] -= $self->{avail_height} * $page_step; 510 } 511 $self->__wr_screen(); 512 } 513 } 514 elsif ( $key == VK_PAGE_DOWN || $key == CONTROL_N ) { 515 if ( $self->{last_page_row} >= $#{$self->{rc2idx}} ) { 516 $self->__beep(); 517 } 518 else { 519 my $backup_p_begin = $self->{first_page_row}; 520 $self->{first_page_row} = $self->{avail_height} * ( int( $self->{pos}[ROW] / $self->{avail_height} ) + $page_step ); 521 $self->{last_page_row} = $self->{first_page_row} + $self->{avail_height} - 1; 522 $self->{last_page_row} = $#{$self->{rc2idx}} if $self->{last_page_row} > $#{$self->{rc2idx}}; 523 if ( $self->{pos}[ROW] + $self->{avail_height} > $#{$self->{rc2idx}} 524 || $self->{pos}[COL] > $#{$self->{rc2idx}[$self->{pos}[ROW] + $self->{avail_height}]} 525 ) { 526 $saved_pos = [ $self->{pos}[ROW] - $backup_p_begin, $self->{pos}[COL] ]; 527 $self->{pos}[ROW] = $#{$self->{rc2idx}}; 528 if ( $self->{pos}[COL] > $#{$self->{rc2idx}[$self->{pos}[ROW]]} ) { 529 $self->{pos}[COL] = $#{$self->{rc2idx}[$self->{pos}[ROW]]}; 530 } 531 } 532 else { 533 $self->{pos}[ROW] += $self->{avail_height} * $page_step; 534 } 535 $self->__wr_screen(); 536 } 537 } 538 elsif ( $key == VK_HOME || $key == CONTROL_A ) { 539 if ( $self->{pos}[COL] == 0 && $self->{pos}[ROW] == 0 ) { 540 $self->__beep(); 541 } 542 else { 543 $self->{pos}[ROW] = 0; 544 $self->{pos}[COL] = 0; 545 $self->{first_page_row} = 0; 546 $self->{last_page_row} = $self->{first_page_row} + $self->{avail_height} - 1; 547 $self->{last_page_row} = $#{$self->{rc2idx}} if $self->{last_page_row} > $#{$self->{rc2idx}}; 548 $self->__wr_screen(); 549 } 550 } 551 elsif ( $key == VK_END || $key == CONTROL_E ) { 552 if ( $self->{order} == 1 && $self->{idx_of_last_col_in_last_row} < $#{$self->{rc2idx}[0]} ) { 553 if ( $self->{pos}[ROW] == $#{$self->{rc2idx}} - 1 554 && $self->{pos}[COL] == $#{$self->{rc2idx}[$self->{pos}[ROW]]} 555 ) { 556 $self->__beep(); 557 } 558 else { 559 $self->{first_page_row} = @{$self->{rc2idx}} - ( @{$self->{rc2idx}} % $self->{avail_height} || $self->{avail_height} ); 560 $self->{pos}[ROW] = $#{$self->{rc2idx}} - 1; 561 $self->{pos}[COL] = $#{$self->{rc2idx}[$self->{pos}[ROW]]}; 562 if ( $self->{first_page_row} == $#{$self->{rc2idx}} ) { 563 $self->{first_page_row} = $self->{first_page_row} - $self->{avail_height}; 564 $self->{last_page_row} = $self->{first_page_row} + $self->{avail_height} - 1; 565 } 566 else { 567 $self->{last_page_row} = $#{$self->{rc2idx}}; 568 } 569 $self->__wr_screen(); 570 } 571 } 572 else { 573 if ( $self->{pos}[ROW] == $#{$self->{rc2idx}} 574 && $self->{pos}[COL] == $#{$self->{rc2idx}[$self->{pos}[ROW]]} 575 ) { 576 $self->__beep(); 577 } 578 else { 579 $self->{first_page_row} = @{$self->{rc2idx}} - ( @{$self->{rc2idx}} % $self->{avail_height} || $self->{avail_height} ); 580 $self->{last_page_row} = $#{$self->{rc2idx}}; 581 $self->{pos}[ROW] = $#{$self->{rc2idx}}; 582 $self->{pos}[COL] = $#{$self->{rc2idx}[$self->{pos}[ROW]]}; 583 $self->__wr_screen(); 584 } 585 } 586 } 587 elsif ( $key == KEY_q || $key == CONTROL_Q ) { 588 $self->__reset_term( 1 ); 589 return; 590 } 591 elsif ( $key == CONTROL_C ) { 592 $self->__reset_term( 1 ); 593 print STDERR "^C\n"; 594 exit 1; 595 } 596 elsif ( $key == LINE_FEED || $key == CARRIAGE_RETURN ) { # LINE_FEED == CONTROL_J, CARRIAGE_RETURN == CONTROL_M # ENTER key 597 if ( length $self->{search_info} ) { 598 require Term::Choose::Opt::Search; 599 $self->Term::Choose::Opt::Search::__search_end(); 600 next GET_KEY; 601 } 602 my $opt_index = $self->{index} || $self->{ll}; 603 my $list_idx = $self->{rc2idx}[$self->{pos}[ROW]][$self->{pos}[COL]]; 604 if ( ! defined $self->{wantarray} ) { 605 $self->__reset_term( 1 ); 606 return; 607 } 608 elsif ( $self->{wantarray} ) { 609 if ( $self->{include_highlighted} == 1 ) { 610 $self->{marked}[$self->{pos}[ROW]][$self->{pos}[COL]] = 1; 611 } 612 elsif ( $self->{include_highlighted} == 2 ) { 613 my $chosen = $self->__marked_rc2idx(); 614 if ( ! @$chosen ) { 615 $self->{marked}[$self->{pos}[ROW]][$self->{pos}[COL]] = 1; 616 } 617 } 618 if ( defined $self->{meta_items} && ! $self->{marked}[$self->{pos}[ROW]][$self->{pos}[COL]] ) { 619 for my $meta_item ( @{$self->{meta_items}} ) { 620 if ( $meta_item == $list_idx ) { 621 $self->{marked}[$self->{pos}[ROW]][$self->{pos}[COL]] = 1; 622 last; 623 } 624 } 625 } 626 my $chosen = $self->__marked_rc2idx(); 627 $self->__reset_term( 1 ); 628 return $opt_index ? @$chosen : @{$orig_list_ref}[@$chosen]; 629 } 630 else { 631 my $chosen = $opt_index ? $list_idx : $orig_list_ref->[$list_idx]; 632 $self->__reset_term( 1 ); 633 return $chosen; 634 } 635 } 636 elsif ( $key == KEY_SPACE ) { 637 if ( $self->{wantarray} ) { 638 my $list_idx = $self->{rc2idx}[$self->{pos}[ROW]][$self->{pos}[COL]]; 639 my $locked = 0; 640 if ( defined $self->{no_spacebar} || defined $self->{meta_items} ) { 641 for my $no_spacebar ( @{$self->{no_spacebar}||[]}, @{$self->{meta_items}||[]} ) { 642 if ( $list_idx == $no_spacebar ) { 643 ++$locked; 644 last; 645 } 646 } 647 } 648 if ( $locked ) { 649 $self->__beep(); 650 } 651 else { 652 $self->{marked}[$self->{pos}[ROW]][$self->{pos}[COL]] = ! $self->{marked}[$self->{pos}[ROW]][$self->{pos}[COL]]; 653 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] ); 654 } 655 } 656 else { 657 $self->__beep(); 658 } 659 } 660 elsif ( $key == CONTROL_SPACE ) { 661 if ( $self->{wantarray} ) { 662 for my $i ( 0 .. $#{$self->{rc2idx}} ) { 663 for my $j ( 0 .. $#{$self->{rc2idx}[$i]} ) { 664 $self->{marked}[$i][$j] = ! $self->{marked}[$i][$j]; 665 } 666 } 667 if ( $self->{skip_items} ) { 668 $self->Term::Choose::Opt::SkipItems::__unmark_skip_items(); 669 } 670 if ( defined $self->{no_spacebar} ) { 671 $self->__marked_idx2rc( $self->{no_spacebar}, 0 ); 672 } 673 if ( defined $self->{meta_items} ) { 674 $self->__marked_idx2rc( $self->{meta_items}, 0 ); 675 } 676 677 $self->__wr_screen(); 678 } 679 else { 680 $self->__beep(); 681 } 682 } 683 elsif ( $key == CONTROL_F && $self->{search} ) { 684 require Term::Choose::Opt::Search; 685 if ( $self->{ll} ) { 686 $ENV{TC_POS_AT_SEARCH} = $self->{rc2idx}[$self->{pos}[ROW]][$self->{pos}[COL]]; 687 $self->__reset_term( 0 ); 688 return -13; 689 } 690 if ( length $self->{search_info} ) { 691 $self->Term::Choose::Opt::Search::__search_end(); 692 } 693 $self->Term::Choose::Opt::Search::__search_begin(); 694 } 695 else { 696 $self->__beep(); 697 } 698 } 699} 700 701 702sub __beep { 703 my ( $self, $beep ) = @_; 704 if ( $beep ) { 705 print bell(); 706 } 707} 708 709 710sub __prepare_info_and_prompt_lines { 711 my ( $self ) = @_; 712 my $info_w = $self->{term_width}; 713 if ( $^O ne 'MSWin32' && $^O ne 'cygwin' ) { 714 $info_w += WIDTH_CURSOR; 715 } 716 if ( $self->{max_width} && $info_w > $self->{max_width} ) { ## 717 $info_w = $self->{max_width}; 718 } 719 my $prompt = ''; 720 if ( length $self->{info} ) { 721 my $init = $self->{tabs_info}[0] ? $self->{tabs_info}[0] : 0; 722 my $subseq = $self->{tabs_info}[1] ? $self->{tabs_info}[1] : 0; 723 $prompt .= line_fold( 724 $self->{info}, $info_w, 725 { init_tab => ' ' x $init, subseq_tab => ' ' x $subseq, color => $self->{color}, join => 1 } 726 ); 727 } 728 if ( length $self->{prompt} ) { 729 if ( length $prompt ) { 730 $prompt .= "\n"; 731 } 732 my $init = $self->{tabs_prompt}[0] ? $self->{tabs_prompt}[0] : 0; 733 my $subseq = $self->{tabs_prompt}[1] ? $self->{tabs_prompt}[1] : 0; 734 $prompt .= line_fold( 735 $self->{prompt}, $info_w, 736 { init_tab => ' ' x $init, subseq_tab => ' ' x $subseq, color => $self->{color}, join => 1 } 737 ); 738 } 739 if ( $prompt eq '' ) { 740 $self->{prompt_copy} = ''; 741 $self->{count_prompt_lines} = 0; 742 return; 743 } 744 if ( length $self->{search_info} ) { 745 $prompt .= "\n" . $self->{search_info} . ':'; 746 } 747 $self->{prompt_copy} = $prompt; 748 $self->{prompt_copy} .= "\n\r"; 749 # s/\n/\n\r/g; -> stty 'raw' mode and Term::Readkey 'ultra-raw' mode 750 # don't translate newline to carriage return-newline 751 $self->{count_prompt_lines} = $self->{prompt_copy} =~ s/\n/\n\r/g; 752} 753 754 755sub __prepare_footer_line { 756 my ( $self ) = @_; 757 if ( exists $self->{footer_fmt} ) { 758 delete $self->{footer_fmt}; 759 } 760 my $pp_total = int( $#{$self->{rc2idx}} / $self->{avail_height} ) + 1; 761 if ( $self->{page} == 0 ) { 762 # nothing to do 763 } 764 elsif ( $self->{page} == 1 && $pp_total == 1 ) { 765 $self->{avail_height}++; 766 } 767 else { 768 my $pp_total_width = length $pp_total; 769 $self->{footer_fmt} = '--- %0' . $pp_total_width . 'd/' . $pp_total . ' --- '; 770 if ( defined $self->{footer} ) { 771 $self->{footer_fmt} .= $self->{footer}; 772 } 773 if ( print_columns( sprintf $self->{footer_fmt}, $pp_total ) > $self->{avail_width} ) { # color 774 $self->{footer_fmt} = '%0' . $pp_total_width . 'd/' . $pp_total; 775 if ( length( sprintf $self->{footer_fmt}, $pp_total ) > $self->{avail_width} ) { 776 $pp_total_width = $self->{avail_width} if $pp_total_width > $self->{avail_width}; 777 $self->{footer_fmt} = '%0' . $pp_total_width . '.' . $pp_total_width . 's'; 778 } 779 } 780 } 781 $self->{pp_count} = $pp_total; 782} 783 784 785sub __set_cell { 786 my ( $self, $list_idx ) = @_; 787 LOOP: for my $i ( 0 .. $#{$self->{rc2idx}} ) { 788 for my $j ( 0 .. $#{$self->{rc2idx}[$i]} ) { 789 if ( $list_idx == $self->{rc2idx}[$i][$j] ) { 790 $self->{pos} = [ $i, $j ]; 791 last LOOP; 792 } 793 } 794 } 795 $self->{first_page_row} = $self->{avail_height} * int( $self->{pos}[ROW] / $self->{avail_height} ); 796 $self->{last_page_row} = $self->{first_page_row} + $self->{avail_height} - 1; 797 $self->{last_page_row} = $#{$self->{rc2idx}} if $self->{last_page_row} > $#{$self->{rc2idx}}; 798} 799 800 801sub __wr_first_screen { 802 my ( $self ) = @_; 803 $self->__avail_screen_size(); 804 $self->__current_layout(); 805 $self->__list_idx2rc(); 806 $self->__prepare_footer_line(); 807 $self->{avail_height_idx} = $self->{avail_height} - 1; 808 $self->{first_page_row} = 0; 809 $self->{last_page_row} = $self->{avail_height_idx} > $#{$self->{rc2idx}} ? $#{$self->{rc2idx}} : $self->{avail_height_idx}; 810 $self->{i_row} = 0; 811 $self->{i_col} = 0; 812 $self->{pos} = [ 0, 0 ]; 813 $self->{marked} = []; 814 if ( $self->{wantarray} && defined $self->{mark} ) { 815 $self->__marked_idx2rc( $self->{mark}, 1 ); 816 } 817 if ( defined $self->{default} && $self->{default} <= $#{$self->{list}} ) { 818 $self->__set_cell( $self->{default} ); 819 } 820 if ( $self->{clear_screen} ) { 821 print clear_screen(); 822 } 823 else { 824 print "\r" . clear_to_end_of_screen(); 825 } 826 if ( $self->{prompt_copy} ne '' ) { 827 print $self->{prompt_copy}; 828 } 829 $self->__wr_screen(); 830 if ( $self->{mouse} ) { 831 my $abs_cursor_y = $self->{plugin}->__get_cursor_row(); 832 $self->{offset_rows} = $abs_cursor_y - 1 - $self->{i_row}; 833 } 834} 835 836 837sub __wr_screen { 838 my ( $self ) = @_; 839 $self->__goto( 0, 0 ); 840 print "\r" . clear_to_end_of_screen(); 841 if ( defined $self->{footer_fmt} ) { 842 $self->__goto( $self->{avail_height_idx} + 1, 0 ); 843 my $pp_line = sprintf $self->{footer_fmt}, int( $self->{first_page_row} / $self->{avail_height} ) + 1; 844 print $pp_line; 845 $self->{i_col} += print_columns( $pp_line ); 846 } 847 for my $row ( $self->{first_page_row} .. $self->{last_page_row} ) { 848 for my $col ( 0 .. $#{$self->{rc2idx}[$row]} ) { 849 $self->__wr_cell( $row, $col ); 850 } 851 } 852 $self->__wr_cell( $self->{pos}[ROW], $self->{pos}[COL] ); 853} 854 855 856sub __wr_cell { 857 my( $self, $row, $col ) = @_; 858 my $is_current_pos = $row == $self->{pos}[ROW] && $col == $self->{pos}[COL]; 859 my $emphasised = ( $self->{marked}[$row][$col] ? bold_underline() : '' ) . ( $is_current_pos ? reverse_video() : '' ); 860 my $idx = $self->{rc2idx}[$row][$col]; 861 if ( $self->{ll} ) { 862 $self->__goto( $row - $self->{first_page_row}, $col * $self->{col_width_plus} ); 863 $self->{i_col} = $self->{i_col} + $self->{col_width}; 864 if ( $self->{color} ) { 865 my $str = $self->{list}[$idx]; 866 if ( $emphasised ) { 867 if ( $is_current_pos && $self->{color} == 1 ) { 868 # no color for selected cell 869 $str =~ s/(\e\[[\d;]*m)//g; 870 } 871 else { 872 # keep cell marked after color escapes 873 $str =~ s/(\e\[[\d;]*m)/${1}$emphasised/g; 874 } 875 $str = $emphasised . $str; 876 } 877 print $str . normal(); # if \e[ 878 } 879 else { 880 if ( $emphasised ) { 881 print $emphasised . $self->{list}[$idx] . normal(); 882 } 883 else { 884 print $self->{list}[$idx]; 885 } 886 } 887 } 888 else { 889 my $str; 890 if ( $self->{current_layout} == -1 ) { 891 my $x = 0; 892 if ( $col > 0 ) { 893 for my $cl ( 0 .. $col - 1 ) { 894 my $i = $self->{rc2idx}[$row][$cl]; 895 $x += $self->{width_elements}[$i] + $self->{pad}; 896 } 897 } 898 $self->__goto( $row - $self->{first_page_row}, $x ); 899 $self->{i_col} = $self->{i_col} + $self->{width_elements}[$idx]; 900 $str = $self->{list}[$idx]; 901 } 902 else { 903 $self->__goto( $row - $self->{first_page_row}, $col * $self->{col_width_plus} ); 904 $self->{i_col} = $self->{i_col} + $self->{col_width}; 905 $str = $self->__pad_str_to_colwidth( $idx ); 906 } 907 if ( $self->{color} ) { 908 my @color; 909 if ( ! $self->{orig_list}[$idx] ) { 910 if ( ! defined $self->{orig_list}[$idx] ) { 911 @color = $self->{undef} =~ /(\e\[[\d;]*m)/g; 912 } 913 elsif ( ! length $self->{orig_list}[$idx] ) { 914 @color = $self->{empty} =~ /(\e\[[\d;]*m)/g; 915 } 916 } 917 else { 918 @color = $self->{orig_list}[$idx] =~ /(\e\[[\d;]*m)/g; 919 } 920 if ( $emphasised ) { 921 for ( @color ) { 922 # keep cell marked after color escapes 923 $_ .= $emphasised; 924 } 925 $str = $emphasised . $str . normal(); 926 if ( $is_current_pos && $self->{color} == 1 ) { 927 # no color for selected cell 928 @color = (); 929 $str =~ s/\x{feff}//g; 930 } 931 } 932 if ( @color ) { 933 $str =~ s/\x{feff}/shift @color/ge; 934 if ( ! $emphasised ) { 935 $str .= normal(); 936 } 937 } 938 print $str; 939 } 940 else { 941 if ( $emphasised ) { 942 print $emphasised . $str . normal(); 943 } 944 else { 945 print $str; 946 } 947 } 948 } 949} 950 951 952sub __pad_str_to_colwidth { 953 my ( $self, $idx ) = @_; 954 if ( $self->{width_elements}[$idx] < $self->{col_width} ) { 955 if ( $self->{alignment} == 0 ) { 956 return $self->{list}[$idx] . ( " " x ( $self->{col_width} - $self->{width_elements}[$idx] ) ); 957 } 958 elsif ( $self->{alignment} == 1 ) { 959 return " " x ( $self->{col_width} - $self->{width_elements}[$idx] ) . $self->{list}[$idx]; 960 } 961 elsif ( $self->{alignment} == 2 ) { 962 my $all = $self->{col_width} - $self->{width_elements}[$idx]; 963 my $half = int( $all / 2 ); 964 return ( " " x $half ) . $self->{list}[$idx] . ( " " x ( $all - $half ) ); 965 } 966 } 967 elsif ( $self->{width_elements}[$idx] > $self->{col_width} ) { 968 if ( $self->{col_width} > 6 ) { 969 return cut_to_printwidth( $self->{list}[$idx], $self->{col_width} - 3 ) . '...'; 970 } 971 else { 972 return cut_to_printwidth( $self->{list}[$idx], $self->{col_width} ); 973 } 974 } 975 else { 976 return $self->{list}[$idx]; 977 } 978} 979 980 981sub __goto { 982 my ( $self, $newrow, $newcol ) = @_; 983 # up, down, left, right: 1 or greater 984 if ( $newrow > $self->{i_row} ) { 985 print "\r\n" x ( $newrow - $self->{i_row} ); 986 $self->{i_row} = $newrow; 987 $self->{i_col} = 0; 988 } 989 elsif ( $newrow < $self->{i_row} ) { 990 print up( $self->{i_row} - $newrow ); 991 $self->{i_row} = $newrow; 992 } 993 if ( $newcol > $self->{i_col} ) { 994 print right( $newcol - $self->{i_col} ); 995 $self->{i_col} = $newcol; 996 } 997 elsif ( $newcol < $self->{i_col} ) { 998 print left( $self->{i_col} - $newcol ); 999 $self->{i_col} = $newcol; 1000 } 1001} 1002 1003 1004sub __avail_screen_size { 1005 my ( $self ) = @_; 1006 ( $self->{avail_width}, $self->{avail_height} ) = ( $self->{term_width}, $self->{term_height} ); 1007 if ( $self->{col_width} > $self->{avail_width} && $^O ne 'MSWin32' && $^O ne 'cygwin' ) { 1008 $self->{avail_width} += WIDTH_CURSOR; 1009 # + WIDTH_CURSOR: use also the last terminal column if there is only one print-column; 1010 # with only one print-column the output doesn't get messed up if an item 1011 # reaches the right edge of the terminal on a non-MSWin32-OS 1012 } 1013 #if ( $self->{ll} && $self->{ll} > $self->{avail_width} ) { 1014 # return -2; 1015 #} 1016 if ( $self->{max_width} && $self->{avail_width} > $self->{max_width} ) { 1017 $self->{avail_width} = $self->{max_width}; 1018 } 1019 if ( $self->{avail_width} < 1 ) { 1020 $self->{avail_width} = 1; 1021 } 1022 $self->__prepare_info_and_prompt_lines(); 1023 if ( $self->{count_prompt_lines} ) { 1024 $self->{avail_height} -= $self->{count_prompt_lines}; 1025 } 1026 if ( $self->{page} ) { 1027 $self->{avail_height}--; 1028 } 1029 if ( $self->{avail_height} < $self->{keep} ) { 1030 $self->{avail_height} = $self->{term_height} >= $self->{keep} ? $self->{keep} : $self->{term_height}; 1031 } 1032 if ( $self->{max_height} && $self->{max_height} < $self->{avail_height} ) { 1033 $self->{avail_height} = $self->{max_height}; 1034 } 1035} 1036 1037 1038sub __current_layout { 1039 my ( $self ) = @_; 1040 my $all_in_first_row; 1041 if ( $self->{layout} <= 1 && ! $self->{ll} && ! $self->{max_cols} ) { 1042 my $firstrow_width = 0; 1043 for my $list_idx ( 0 .. $#{$self->{list}} ) { 1044 $firstrow_width += $self->{width_elements}[$list_idx] + $self->{pad}; 1045 if ( $firstrow_width - $self->{pad} > $self->{avail_width} ) { 1046 $firstrow_width = 0; 1047 last; 1048 } 1049 } 1050 $all_in_first_row = $firstrow_width; 1051 } 1052 if ( $all_in_first_row ) { 1053 $self->{current_layout} = -1; 1054 } 1055 elsif ( $self->{col_width} >= $self->{avail_width} ) { 1056 $self->{current_layout} = 2; 1057 $self->{col_width} = $self->{avail_width}; 1058 } 1059 else { 1060 $self->{current_layout} = $self->{layout}; 1061 } 1062 $self->{col_width_plus} = $self->{col_width} + $self->{pad}; 1063 # 'col_width_plus' no effects if layout == 2 1064} 1065 1066 1067sub __list_idx2rc { 1068 my ( $self ) = @_; 1069 my $layout = $self->{current_layout}; 1070 $self->{rc2idx} = []; 1071 if ( $layout == -1 ) { 1072 $self->{rc2idx}[0] = [ 0 .. $#{$self->{list}} ]; 1073 $self->{idx_of_last_col_in_last_row} = $#{$self->{list}}; 1074 } 1075 elsif ( $layout == 2 ) { 1076 for my $list_idx ( 0 .. $#{$self->{list}} ) { 1077 $self->{rc2idx}[$list_idx][0] = $list_idx; 1078 $self->{idx_of_last_col_in_last_row} = 0; 1079 } 1080 } 1081 else { 1082 my $tmp_avail_width = $self->{avail_width} + $self->{pad}; 1083 # auto_format 1084 if ( $layout == 1 ) { 1085 my $tmc = int( @{$self->{list}} / $self->{avail_height} ); 1086 $tmc++ if @{$self->{list}} % $self->{avail_height}; 1087 $tmc *= $self->{col_width_plus}; 1088 if ( $tmc < $tmp_avail_width ) { 1089 $tmc = int( $tmc + ( ( $tmp_avail_width - $tmc ) / 1.5 ) ); 1090 $tmp_avail_width = $tmc; 1091 } 1092 } 1093 # order 1094 my $cols_per_row = int( $tmp_avail_width / $self->{col_width_plus} ); 1095 if ( $self->{max_cols} && $cols_per_row > $self->{max_cols} ) { 1096 $cols_per_row = $self->{max_cols}; 1097 } 1098 $cols_per_row = 1 if $cols_per_row < 1; 1099 $self->{idx_of_last_col_in_last_row} = ( @{$self->{list}} % $cols_per_row || $cols_per_row ) - 1; 1100 if ( $self->{order} == 1 ) { 1101 my $rows = int( ( @{$self->{list}} - 1 + $cols_per_row ) / $cols_per_row ); 1102 my @rearranged_idx; 1103 my $begin = 0; 1104 my $end = $rows - 1 ; 1105 for my $c ( 0 .. $cols_per_row - 1 ) { 1106 --$end if $c > $self->{idx_of_last_col_in_last_row}; 1107 $rearranged_idx[$c] = [ $begin .. $end ]; 1108 $begin = $end + 1; 1109 $end = $begin + $rows - 1; 1110 } 1111 for my $r ( 0 .. $rows - 1 ) { 1112 my @temp_idx; 1113 for my $c ( 0 .. $cols_per_row - 1 ) { 1114 next if $r == $rows - 1 && $c > $self->{idx_of_last_col_in_last_row}; 1115 push @temp_idx, $rearranged_idx[$c][$r]; 1116 } 1117 push @{$self->{rc2idx}}, \@temp_idx; 1118 } 1119 } 1120 else { 1121 my $begin = 0; 1122 my $end = $cols_per_row - 1; 1123 $end = $#{$self->{list}} if $end > $#{$self->{list}}; 1124 push @{$self->{rc2idx}}, [ $begin .. $end ]; 1125 while ( $end < $#{$self->{list}} ) { 1126 $begin += $cols_per_row; 1127 $end += $cols_per_row; 1128 $end = $#{$self->{list}} if $end > $#{$self->{list}}; 1129 push @{$self->{rc2idx}}, [ $begin .. $end ]; 1130 } 1131 } 1132 } 1133} 1134 1135 1136sub __marked_idx2rc { 1137 my ( $self, $list_of_indexes, $boolean ) = @_; 1138 my $last_list_idx = $#{$self->{list}}; 1139 if ( $self->{current_layout} == 2 ) { 1140 for my $list_idx ( @$list_of_indexes ) { 1141 if ( $list_idx > $last_list_idx ) { 1142 next; 1143 } 1144 $self->{marked}[$list_idx][0] = $boolean; 1145 } 1146 return; 1147 } 1148 my ( $row, $col ); 1149 my $cols_per_row = @{$self->{rc2idx}[0]}; 1150 if ( $self->{order} == 0 ) { 1151 for my $list_idx ( @$list_of_indexes ) { 1152 if ( $list_idx > $last_list_idx ) { 1153 next; 1154 } 1155 $row = int( $list_idx / $cols_per_row ); 1156 $col = $list_idx % $cols_per_row; 1157 $self->{marked}[$row][$col] = $boolean; 1158 } 1159 } 1160 elsif ( $self->{order} == 1 ) { 1161 my $rows_per_col = @{$self->{rc2idx}}; 1162 my $col_count_last_row = $self->{idx_of_last_col_in_last_row} + 1; 1163 my $last_list_idx_in_cols_full = $rows_per_col * $col_count_last_row - 1; 1164 my $first_list_idx_in_cols_short = $last_list_idx_in_cols_full + 1; 1165 1166 for my $list_idx ( @$list_of_indexes ) { 1167 if ( $list_idx > $last_list_idx ) { 1168 next; 1169 } 1170 if ( $list_idx < $last_list_idx_in_cols_full ) { 1171 $row = $list_idx % $rows_per_col; 1172 $col = int( $list_idx / $rows_per_col ); 1173 } 1174 else { 1175 my $rows_per_col_short = $rows_per_col - 1; 1176 $row = ( $list_idx - $first_list_idx_in_cols_short ) % $rows_per_col_short; 1177 $col = int( ( $list_idx - $col_count_last_row ) / $rows_per_col_short ); 1178 } 1179 $self->{marked}[$row][$col] = $boolean; 1180 } 1181 } 1182} 1183 1184 1185sub __marked_rc2idx { 1186 my ( $self ) = @_; 1187 my $list_idx = []; 1188 if ( $self->{order} == 1 ) { 1189 for my $col ( 0 .. $#{$self->{rc2idx}[0]} ) { 1190 for my $row ( 0 .. $#{$self->{rc2idx}} ) { 1191 if ( $self->{marked}[$row][$col] ) { 1192 push @$list_idx, $self->{rc2idx}[$row][$col]; 1193 } 1194 } 1195 } 1196 } 1197 else { 1198 for my $row ( 0 .. $#{$self->{rc2idx}} ) { 1199 for my $col ( 0 .. $#{$self->{rc2idx}[$row]} ) { 1200 if ( $self->{marked}[$row][$col] ) { 1201 push @$list_idx, $self->{rc2idx}[$row][$col]; 1202 } 1203 } 1204 } 1205 } 1206 return $list_idx; 1207} 1208 1209 12101; 1211 1212 1213__END__ 1214 1215=pod 1216 1217=encoding UTF-8 1218 1219=head1 NAME 1220 1221Term::Choose - Choose items from a list interactively. 1222 1223=head1 VERSION 1224 1225Version 1.745 1226 1227=cut 1228 1229=head1 SYNOPSIS 1230 1231Functional interface: 1232 1233 use Term::Choose qw( choose ); 1234 1235 my $array_ref = [ qw( one two three four five ) ]; 1236 1237 my $choice = choose( $array_ref ); # single choice 1238 print "$choice\n"; 1239 1240 my @choices = choose( [ 1 .. 100 ], { alignment => 1 } ); # multiple choice 1241 print "@choices\n"; 1242 1243 choose( [ 'Press ENTER to continue' ], { prompt => '' } ); # no choice 1244 1245Object-oriented interface: 1246 1247 use Term::Choose; 1248 1249 my $array_ref = [ qw( one two three four five ) ]; 1250 1251 my $new = Term::Choose->new(); 1252 1253 my $choice = $new->choose( $array_ref ); # single choice 1254 print "$choice\n"; 1255 1256 my @choices = $new->choose( [ 1 .. 100 ] ); # multiple choice 1257 print "@choices\n"; 1258 1259 my $stopp = Term::Choose->new( { prompt => '' } ); 1260 $stopp->choose( [ 'Press ENTER to continue' ] ); # no choice 1261 1262=head1 DESCRIPTION 1263 1264Choose interactively from a list of items. 1265 1266C<Term::Choose> provides a functional interface (L</SUBROUTINES>) and an object-oriented interface (L</METHODS>). 1267 1268=head1 EXPORT 1269 1270Nothing by default. 1271 1272 use Term::Choose qw( choose ); 1273 1274=head1 METHODS 1275 1276=head2 new 1277 1278 $new = Term::Choose->new( \%options ); 1279 1280This constructor returns a new C<Term::Choose> object. 1281 1282To set the different options it can be passed a reference to a hash as an optional argument. 1283 1284For detailed information about the options see L</OPTIONS>. 1285 1286=head2 choose 1287 1288The method C<choose> allows the user to choose from a list. 1289 1290The first argument is an array reference which holds the list of the available choices. 1291 1292As a second and optional argument it can be passed a reference to a hash where the keys are the option names and the 1293values the option values. 1294 1295Options set with C<choose> overwrite options set with C<new>. Before leaving C<choose> restores the 1296overwritten options. 1297 1298 $choice = $new->choose( $array_ref, \%options ); 1299 1300 @choices= $new->choose( $array_ref, \%options ); 1301 1302 $new->choose( $array_ref, \%options ); 1303 1304When in the documentation is mentioned "array" or "list" or "elements" or "items" (of the array/list) than these 1305refer to this array passed as a reference as the first argument. 1306 1307For more information how to use C<choose> and its return values see L<USAGE AND RETURN VALUES>. 1308 1309=head1 SUBROUTINES 1310 1311=head2 choose 1312 1313The function C<choose> allows the user to choose from a list. It takes the same arguments as the method L</choose>. 1314 1315 $choice = choose( $array_ref, \%options ); 1316 1317 @choices= choose( $array_ref, \%options ); 1318 1319 choose( $array_ref, \%options ); 1320 1321See the L</OPTIONS> section for more details about the different options and how to set them. 1322 1323See also the following section L<USAGE AND RETURN VALUES>. 1324 1325=head1 USAGE AND RETURN VALUES 1326 1327=over 1328 1329=item * 1330 1331If C<choose> is called in a I<scalar context>, the user can choose an item by using the L</Keys to move around> and 1332confirming with C<Return>. 1333 1334C<choose> then returns the chosen item. 1335 1336=item * 1337 1338If C<choose> is called in an I<list context>, the user can also mark an item with the C<SpaceBar>. 1339 1340C<choose> then returns - when C<Return> is pressed - the list of marked items (including the highlighted item if the 1341option I<include_highlighted> is set to C<1>). 1342 1343In I<list context> C<Ctrl-SpaceBar> (or C<Ctrl-@>) inverts the choices: marked items are unmarked and unmarked items are 1344marked. 1345 1346=item * 1347 1348If C<choose> is called in an I<void context>, the user can move around but mark nothing; the output shown by C<choose> 1349can be closed with C<Return>. 1350 1351Called in void context C<choose> returns nothing. 1352 1353If the first argument refers to an empty array, C<choose> returns nothing. 1354 1355=back 1356 1357If the items of the list don't fit on the screen, the user can scroll to the next (previous) page(s). 1358 1359If the window size is changed, then as soon as the user enters a keystroke C<choose> rewrites the screen. 1360 1361C<choose> returns C<undef> or an empty list in list context if the C<q> key (or C<Ctrl-Q>) is pressed. 1362 1363If the I<mouse> mode is enabled, an item can be chosen with the left mouse key, in list context the right mouse key can 1364be used instead the C<SpaceBar> key. 1365 1366Pressing the C<Ctrl-F> allows one to enter a regular expression so that only the items that match the regular expression 1367are displayed. When going back to the unfiltered menu (C<Enter>) the item highlighted in the filtered menu keeps the 1368highlighting. Also (in I<list context>) marked items retain there markings. The Perl function C<readline> is used to 1369read the regular expression if L<Term::Form> is not available. See option I<search>. 1370 1371=head2 Keys to move around 1372 1373=over 1374 1375=item * 1376 1377the C<Arrow> keys (or the C<h,j,k,l> keys) to move up and down or to move to the right and to the left, 1378 1379=item * 1380 1381the C<Tab> key (or C<Ctrl-I>) to move forward, the C<BackSpace> key (or C<Ctrl-H> or C<Shift-Tab>) to move backward, 1382 1383=item * 1384 1385the C<PageUp> key (or C<Ctrl-P>) to go to the previous page, the C<PageDown> key (or C<Ctrl-N>) to go to the next page, 1386 1387=item * 1388 1389the C<Insert> key to go back 10 pages, the C<Delete> key to go forward 10 pages, 1390 1391=item * 1392 1393the C<Home> key (or C<Ctrl-A>) to jump to the beginning of the list, the C<End> key (or C<Ctrl-E>) to jump to the end of 1394the list. 1395 1396=back 1397 1398=head2 Modifications for the output 1399 1400For the output on the screen the array elements are modified. 1401 1402All the modifications are made on a copy of the original array so C<choose> returns the chosen elements as they were 1403passed to the function without modifications. 1404 1405Modifications: 1406 1407=over 1408 1409=item * 1410 1411If an element is not defined the value from the option I<undef> is assigned to the element. 1412 1413=item * 1414 1415If an element holds an empty string the value from the option I<empty> is assigned to the element. 1416 1417=item * 1418 1419Tab characters in elements are replaces with a space. 1420 1421 $element =~ s/\t/ /g; 1422 1423=item * 1424 1425Vertical spaces in elements are squashed to two spaces. 1426 1427 $element =~ s/\v+/\ \ /g; 1428 1429=item * 1430 1431Code points from the ranges of control, surrogate and noncharacter are removed. 1432 1433 $element =~ s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]//g; 1434 1435=item * 1436 1437If the length of an element is greater than the width of the screen the element is cut and at the end of the string are 1438added three dots. 1439 1440=back 1441 1442=head1 OPTIONS 1443 1444Options which expect a number as their value expect integers. 1445 1446=head3 alignment 1447 14480 - elements ordered in columns are aligned to the left (default) 1449 14501 - elements ordered in columns are aligned to the right 1451 14522 - elements ordered in columns are centered 1453 1454=head3 beep 1455 14560 - off (default) 1457 14581 - on 1459 1460=head3 clear_screen 1461 14620 - off (default) 1463 14641 - clears the screen before printing the choices 1465 1466=head3 codepage_mapping 1467 1468This option has only meaning if the operating system is MSWin32. 1469 1470If the OS is MSWin32, L<Win32::Console::ANSI> is used. By default C<Win32::Console::ANSI> converts the characters from 1471Windows code page to DOS code page (the so-called ANSI to OEM conversion). This conversation is disabled by default in 1472C<Term::Choose> but one can enable it by setting this option. 1473 1474Setting this option to C<1> enables the codepage mapping offered by L<Win32::Console::ANSI>. 1475 14760 - disable automatic codepage mapping (default) 1477 14781 - keep automatic codepage mapping 1479 1480=head3 color 1481 1482Enable the support for color and text formatting escape sequences. 1483 14840 - off (default) 1485 14861 - Enables the support for color and text formatting escape sequences except for the current selected element. 1487 14882 - Enables the support for color and text formatting escape sequences including for the current selected element (shown 1489in inverted colors). 1490 1491=head3 default 1492 1493With the option I<default> it can be selected an element, which will be highlighted as the default instead of the first 1494element. 1495 1496I<default> expects a zero indexed value, so e.g. to highlight the third element the value would be I<2>. 1497 1498If the passed value is greater than the index of the last array element the first element is highlighted. 1499 1500Allowed values: 0 or greater 1501 1502(default: undefined) 1503 1504=head3 empty 1505 1506Sets the string displayed on the screen instead an empty string. 1507 1508(default: "<empty>") 1509 1510=head3 footer 1511 1512Add a string in the bottom line. 1513 1514If a footer string is passed with this option, the option I<page> is automatically set to C<2>. 1515 1516(default: undefined) 1517 1518=head3 hide_cursor 1519 15200 - keep the terminals highlighting of the cursor position 1521 15221 - hide the terminals highlighting of the cursor position (default) 1523 1524=head3 info 1525 1526Expects as its value a string. The info text is printed above the prompt string. 1527 1528(default: not set) 1529 1530=head3 index 1531 15320 - off (default) 1533 15341 - return the index of the chosen element instead of the chosen element respective the indices of the chosen elements 1535instead of the chosen elements. 1536 1537=head3 keep 1538 1539I<keep> prevents that all the terminal rows are used by the prompt lines. 1540 1541Setting I<keep> ensures that at least I<keep> terminal rows are available for printing list rows. 1542 1543If the terminal height is less than I<keep> I<keep> is set to the terminal height. 1544 1545Allowed values: 1 or greater 1546 1547(default: 5) 1548 1549=head3 layout 1550 1551=over 1552 1553=item * 1554 15550 - layout off 1556 1557 .----------------------. .----------------------. .----------------------. .----------------------. 1558 | .. .. .. .. .. .. .. | | .. .. .. .. .. .. .. | | .. .. .. .. .. .. .. | | .. .. .. .. .. .. .. | 1559 | | | .. .. .. .. .. .. .. | | .. .. .. .. .. .. .. | | .. .. .. .. .. .. .. | 1560 | | | | | .. .. .. .. .. | | .. .. .. .. .. .. .. | 1561 | | | | | | | .. .. .. .. .. .. .. | 1562 | | | | | | | .. .. .. .. .. .. .. | 1563 | | | | | | | .. .. .. .. .. .. .. | 1564 '----------------------' '----------------------' '----------------------' '----------------------' 1565 1566=item * 1567 15681 - default 1569 1570 .----------------------. .----------------------. .----------------------. .----------------------. 1571 | .. .. .. .. .. .. .. | | .. .. .. .. .. | | .. .. .. .. .. .. | | .. .. .. .. .. .. .. | 1572 | | | .. .. .. .. .. | | .. .. .. .. .. .. | | .. .. .. .. .. .. .. | 1573 | | | .. .. | | .. .. .. .. .. .. | | .. .. .. .. .. .. .. | 1574 | | | | | .. .. .. .. .. .. | | .. .. .. .. .. .. .. | 1575 | | | | | .. .. .. | | .. .. .. .. .. .. .. | 1576 | | | | | | | .. .. .. .. .. .. .. | 1577 '----------------------' '----------------------' '----------------------' '----------------------' 1578 15792 - all in a single column 1580 1581 .----------------------. .----------------------. .----------------------. .----------------------. 1582 | .. | | .. | | .. | | .. | 1583 | .. | | .. | | .. | | .. | 1584 | .. | | .. | | .. | | .. | 1585 | | | .. | | .. | | .. | 1586 | | | | | .. | | .. | 1587 | | | | | | | .. | 1588 '----------------------' '----------------------' '----------------------' '----------------------' 1589 1590=back 1591 1592=head3 ll 1593 1594If all elements have the same length, the length can be passed with this option. C<choose> then doesn't calculate the 1595length of the longest element itself but uses the passed value. I<length> refers here to the number of print columns 1596the element will use on the terminal. 1597 1598If I<ll> is set, C<choose> returns always the index(es) of the chosen item(s) regardless of how I<index> is set. 1599 1600Undefined list elements are not allowed. 1601 1602The replacements described in L</Modifications for the output> are not applied. If elements contain unsupported 1603characters the output might break. 1604 1605If I<ll> is set to a value less than the length of the elements, the output could break. 1606 1607If I<ll> is set and the window size has changed, choose returns immediately C<-1>. 1608 1609Allowed values: 1 or greater 1610 1611(default: undefined) 1612 1613=head3 max_cols 1614 1615Limit the number of columns to I<max_cols>. 1616 1617Allowed values: 1 or greater 1618 1619(default: undefined) 1620 1621=head3 max_height 1622 1623If defined sets the maximal number of rows used for printing list items. 1624 1625If the available height is less than I<max_height> then I<max_height> is set to the available height. 1626 1627Height in this context means print rows. 1628 1629I<max_height> overwrites I<keep> if I<max_height> is set to a value less than I<keep>. 1630 1631Allowed values: 1 or greater 1632 1633(default: undefined) 1634 1635=head3 max_width 1636 1637If defined, sets the maximal output width to I<max_width> if the terminal width is greater than I<max_width>. 1638 1639To prevent the "auto-format" to use a width less than I<max_width> set I<layout> to 0. 1640 1641Width refers here to the number of print columns. 1642 1643Allowed values: 1 or greater 1644 1645(default: undefined) 1646 1647=head3 mouse 1648 16490 - off (default) 1650 16511 - on. Enables the Any-Event-Mouse-Mode (1003) and the Extended-SGR-Mouse-Mode (1006). 1652 1653If the option I<mouse> is enabled layers for C<STDIN> are changed. Then before leaving C<choose> as a cleanup C<STDIN> 1654is marked as C<UTF-8> with C<:encoding(UTF-8)>. This doesn't apply if the OS is MSWin32. 1655 1656If the OS is MSWin32 the mouse is enabled with the help of L<Win32::Console>. 1657 1658=head3 order 1659 1660If the output has more than one row and more than one column: 1661 16620 - elements are ordered horizontally 1663 16641 - elements are ordered vertically (default) 1665 1666Default may change in a future release. 1667 1668=head3 pad 1669 1670Sets the number of whitespaces between columns. (default: 2) 1671 1672Allowed values: 0 or greater 1673 1674=head3 page 1675 16760 - off 1677 16781 - print the page number on the bottom of the screen. If all the choices fit into one page, the page number is not 1679displayed. (default) 1680 16812 - the page number is always displayed even with only one page. Setting I<page> to C<2> automatically enables the 1682option L<clear_screen>. 1683 1684=head3 prompt 1685 1686If I<prompt> is undefined a default prompt-string will be shown. 1687 1688If the I<prompt> value is an empty string ("") no prompt-line will be shown. 1689 1690default in list and scalar context: C<Your choice:> 1691 1692default in void context: C<Close with ENTER> 1693 1694=head3 search 1695 1696Set the behavior of C<Ctrl-F>. 1697 16980 - off 1699 17001 - case-insensitive search (default) 1701 17022 - case-sensitive search 1703 1704=head3 skip_items 1705 1706When navigating through the list, the elements that match the regex pattern passed with this option will be skipped. 1707 1708In list context: these elements cannot be marked. 1709 1710Expected value: a regex quoted with the C<qr> operator. 1711 1712(default: undefined) 1713 1714=head3 tabs_info 1715 1716If I<info> lines are folded, the option I<tabs_info> allows one to insert spaces at beginning of the folded lines. 1717 1718The option I<tabs_info> expects a reference to an array with one or two elements: 1719 1720- the first element (initial tab) sets the number of spaces inserted at beginning of paragraphs 1721 1722- a second element (subsequent tab) sets the number of spaces inserted at the beginning of all broken lines apart 1723from the beginning of paragraphs 1724 1725Allowed values: 0 or greater. Elements beyond the second are ignored. 1726 1727(default: undefined) 1728 1729=head3 tabs_prompt 1730 1731If I<prompt> lines are folded, the option I<tabs_prompt> allows one to insert spaces at beginning of the folded lines. 1732 1733The option I<tabs_prompt> expects a reference to an array with one or two elements: 1734 1735- the first element (initial tab) sets the number of spaces inserted at beginning of paragraphs 1736 1737- a second element (subsequent tab) sets the number of spaces inserted at the beginning of all broken lines apart 1738from the beginning of paragraphs 1739 1740Allowed values: 0 or greater. Elements beyond the second are ignored. 1741 1742(default: undefined) 1743 1744=head3 undef 1745 1746Sets the string displayed on the screen instead an undefined element. 1747 1748default: "<undef>" 1749 1750=head2 Options List Context 1751 1752=head3 include_highlighted 1753 1754In list context when C<Return> is pressed 1755 17560 - C<choose> returns the items marked with the C<SpaceBar>. (default) 1757 17581 - C<choose> returns the items marked with the C<SpaceBar> plus the highlighted item. 1759 17602 - C<choose> returns the items marked with the C<SpaceBar>. If no items are marked with the C<SpaceBar>, the 1761highlighted item is returned. 1762 1763=head3 mark 1764 1765I<mark> expects as its value a reference to an array. The elements of the array are list indexes. C<choose> preselects 1766the list-elements correlating to these indexes. 1767 1768Elements greater than the last index of the list are ignored. 1769 1770This option has only meaning in list context. 1771 1772(default: undefined) 1773 1774=head3 meta_items 1775 1776I<meta_items> expects as its value a reference to an array. The elements of the array are list indexes. These elements 1777can not be marked with the C<SpaceBar> or with the right mouse key but if one of these elements is the highlighted item 1778it is added to the chosen items when C<Return> is pressed. 1779 1780Elements greater than the last index of the list are ignored. 1781 1782This option has only meaning in list context. 1783 1784(default: undefined) 1785 1786=head3 no_spacebar 1787 1788I<no_spacebar> expects as its value a reference to an array. The elements of the array are indexes of the list which 1789should not be markable with the C<SpaceBar> or with the right mouse key. 1790 1791If an element is preselected with the option I<mark> and also marked as not selectable with the option I<no_spacebar>, 1792the user can not remove the preselection of this element. 1793 1794I<no_spacebar> elements greater than the last index of the list are ignored. 1795 1796This option has only meaning in list context. 1797 1798(default: undefined) 1799 1800=head1 ERROR HANDLING 1801 1802=head2 croak 1803 1804C<new|choose> croaks if passed invalid arguments. 1805 1806=head2 carp 1807 1808If pressing a key results in an undefined value C<choose> carps with C<EOT: $!> and returns I<undef> or an empty list in 1809list context. 1810 1811=head1 REQUIREMENTS 1812 1813=head2 Perl version 1814 1815Requires Perl version 5.10.0 or greater. 1816 1817=head2 Optional modules 1818 1819=head3 Term::ReadKey 1820 1821If L<Term::ReadKey> is available it is used C<ReadKey> to read the user input and C<GetTerminalSize> to get the 1822terminal size. Without C<Term::ReadKey> C<getc> is used to read the input and C<stty size> to get the terminal size. 1823 1824If the OS is MSWin32 it is used L<Win32::Console> to read the user input and to get the terminal size. 1825 1826=head2 Decoded strings 1827 1828C<choose> expects decoded strings as array elements. 1829 1830=head2 Encoding layer for STDOUT 1831 1832For a correct output it is required an appropriate encoding layer for STDOUT matching the terminal's character set. 1833 1834=head2 Monospaced font 1835 1836It is required a terminal that uses a monospaced font which supports the printed characters. 1837 1838=head2 Ambiguous width characters 1839 1840By default ambiguous width characters are treated as half width. If the environment variable C<TC_AMBIGUOUS_WIDE> is set 1841to a true value, ambiguous width characters are treated as full width. 1842 1843=head2 Escape sequences 1844 1845By default C<Term::Choose> uses C<tput> to get the appropriate escape sequences. Setting the environment variable 1846C<TC_ANSI_ESCAPES> to a true value allows one to use ANSI escape sequences directly without calling C<tput>. 1847 1848 BEGIN { 1849 $ENV{TC_ANSI_ESCAPES} = 1; 1850 } 1851 use Term::Choose qw( choose ); 1852 1853The escape sequences to enable the I<mouse> mode are always hardcoded. 1854 1855=head2 MSWin32 1856 1857If the OS is MSWin32 L<Win32::Console> and L<Win32::Console::ANSI> with ANSI escape sequences are used. See also 1858L</codepage_mapping>. 1859 1860=head1 SUPPORT 1861 1862You can find documentation for this module with the perldoc command. 1863 1864 perldoc Term::Choose 1865 1866=head1 AUTHOR 1867 1868Matthäus Kiem <cuer2s@gmail.com> 1869 1870=head1 CREDITS 1871 1872Based on the C<choose> function from the L<Term::Clui> module. 1873 1874Thanks to the L<Perl-Community.de|http://www.perl-community.de> and the people form 1875L<stackoverflow|http://stackoverflow.com> for the help. 1876 1877=head1 LICENSE AND COPYRIGHT 1878 1879Copyright (C) 2012-2021 Matthäus Kiem. 1880 1881This library is free software; you can redistribute it and/or modify it under the same terms as Perl 5.10.0. For 1882details, see the full text of the licenses in the file LICENSE. 1883 1884=cut 1885