File Coverage

blib/lib/CTK/CLI.pm
Criterion Covered Total %
statement 15 47 31.9
branch 0 22 0.0
condition 0 23 0.0
subroutine 5 8 62.5
pod 2 2 100.0
total 22 102 21.5


line stmt bran cond sub pod time code
1             package CTK::CLI; # $Id: CLI.pm 253 2019-05-09 19:32:24Z minus $
2 2     2   15 use strict;
  2         4  
  2         113  
3 2     2   13 use utf8;
  2         4  
  2         48  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::CLI - Command line interface
10              
11             =head1 VERSION
12              
13             Version 1.72
14              
15             =head1 SYNOPSIS
16              
17             use CTK::CLI qw/cli_prompt cli_select/;
18              
19             my $v = cli_prompt('Your name:', 'anonymous');
20             debug( "Your name: $v" );
21              
22             my $v = cli_select('Your select:',[qw/foo bar baz/],'bar');
23             debug( "Your select: $v" );
24              
25             or in CTK context (as plugin):
26              
27             my $v = $ctk->cli_prompt('Your name:', 'anonymous');
28             debug( "Your name: $v" );
29              
30             my $v = $ctk->cli_select('Your select:',[qw/foo bar baz/],'bar');
31             debug( "Your select: $v" );
32              
33             =head1 DESCRIPTION
34              
35             Command line interface. Prompt and select methods
36              
37             =head2 cli_prompt
38              
39             my $v = cli_prompt('Your name:', 'anonymous');
40             debug( "Your name: $v" );
41              
42             Show prompt string for typing data
43              
44             =head2 cli_select
45              
46             my $v = cli_select('Your select:',[qw/foo bar baz/],'bar');
47             debug( "Your select: $v" );
48              
49             Show prompt string for select item
50              
51             =head1 HISTORY
52              
53             See C file
54              
55             =head1 DEPENDENCIES
56              
57             L
58              
59             =head1 TO DO
60              
61             * Use Term::ReadLine module. Sample:
62              
63             BEGIN { $ENV{TERM} = "dumb" if $^O eq "MSWin32" }
64             use Term::ReadLine ();
65             use Text::ParseWords qw(shellwords);
66              
67             my $term = new Term::ReadLine 'T01';
68             my $prompt = "T> ";
69             my $OUT = $term->OUT || \*STDOUT;
70             while ( defined ($_ = $term->readline($prompt)) ) {
71             last if /^(quit|exit)$/;
72             my @w = shellwords($_);
73             if (@w) {
74             print join(" ",@w),"\n";
75             $term->addhistory($_);
76             }
77             }
78             print "\n";
79              
80             =head1 BUGS
81              
82             * none noted
83              
84             =head1 SEE ALSO
85              
86             L
87              
88             =head1 AUTHOR
89              
90             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
91              
92             =head1 COPYRIGHT
93              
94             Copyright (C) 1998-2019 D&D Corporation. All Rights Reserved
95              
96             =head1 LICENSE
97              
98             This program is free software; you can redistribute it and/or
99             modify it under the same terms as Perl itself.
100              
101             See C file and L
102              
103             =cut
104              
105 2     2   106 use vars qw/$VERSION @EXPORT_OK/;
  2         3  
  2         144  
106             $VERSION = '1.72';
107              
108 2     2   22 use base qw/Exporter/;
  2         4  
  2         185  
109              
110 2     2   1711 use ExtUtils::MakeMaker qw/prompt/;
  2         200527  
  2         1033  
111              
112             @EXPORT_OK = (qw/
113             cli_prompt cli_select
114             /);
115              
116             sub cli_prompt {
117             # my $a = prompt('Input value a', '123');
118 0 0 0 0 1   my $self; $self = shift if (@_ && $_[0] && ref($_[0]));
  0   0        
119 0           my $msg = shift;
120 0           my $def = shift;
121 0           return prompt($msg, $def)
122             }
123             sub cli_select {
124 0 0 0 0 1   my $self; $self = shift if (@_ && $_[0] && ref($_[0]));
  0   0        
125 0           my $msg = shift;
126 0   0       my $sel = shift || [];
127 0           my $def = shift;
128              
129 0           my $v = _cli_select($sel);
130 0 0         my $d = defined($def) ? $def : $v->[1];
131 0 0         print($v->[1],"\n") if $v->[0];
132 0 0         $v = cli_prompt(defined($msg) ? $msg : '', $d);
133 0           $v = _cli_select($sel, $v);
134              
135 0 0         return $v->[0] ? '' : $v->[1];
136             }
137              
138             sub _cli_select {
139             # Returns value or list of value, or defult value
140             # First element - 0 - value/default value
141             # 1 - List of values
142 0     0     my $v = shift;
143 0           my $sel = shift;
144 0 0         if (defined $v) {
145 0 0         if (ref $v eq 'ARRAY') {
146 0 0 0       if (defined($sel) && ($sel =~ /^\d+$/) && exists($v->[$sel-1])) {
    0 0        
      0        
147 0           return [0,$v->[$sel-1]];
148 0           } elsif (defined($sel) && grep {$_ eq $sel} @$v) {
149 0           return [0,$sel];
150             } else {
151 0           my $c=0;
152 0           my @r=();
153 0           foreach (@$v) {$c++; push @r, "$c) $_"}
  0            
  0            
154 0           return [1,"Select one item:\n\t".join(";\n\t",@r)."\n"];
155             }
156             } else {
157 0 0         return [0,defined $sel ? $sel : $v];
158             }
159             } else {
160 0           return [0,''];
161             }
162             }
163              
164             1;
165              
166             __END__