1#! /usr//bin/perl 2## 3 4use strict; 5use warnings; 6use English; 7use ExtUtils::testlib; 8use Curses; 9 10 11sub fatal { 12 clrtobot(0, 0); 13 addstr(0, 0, "@_\n"); 14 refresh(); 15 sleep 2; 16 die("Fatal error"); 17} 18 19 20 21sub driveForm($$) { 22 my ($fwinR, $formR) = @_; 23 24 while (1) { 25 my $ch = getch($fwinR); 26 if ($ch eq KEY_UP) { 27 form_driver($formR, REQ_PREV_FIELD); 28 } elsif ($ch eq KEY_DOWN or $ch eq "\t" or 29 $ch eq "\r" or $ch eq "\n") { 30 form_driver($formR, REQ_NEXT_FIELD); 31 } elsif ($ch eq KEY_LEFT) { 32 form_driver($formR, REQ_LEFT_CHAR); 33 } elsif ($ch eq KEY_RIGHT) { 34 form_driver($formR, REQ_RIGHT_CHAR); 35 } elsif ($ch eq KEY_NPAGE) { 36 form_driver($formR, REQ_NEXT_PAGE); 37 } elsif ($ch eq KEY_PPAGE) { 38 form_driver($formR, REQ_PREV_PAGE); 39 } elsif ($ch eq KEY_DC or ord($ch) == 8 or ord($ch) == 127) { 40 form_driver($formR, REQ_DEL_PREV); 41 } elsif ($ch eq KEY_F(1)) { 42 last; 43 } elsif ($ch =~ /^\S$/) { 44 form_driver($formR, ord($ch)); 45 } else { 46 beep(); 47 } 48 } 49} 50 51 52 53sub makeFields() { 54 55 my $fieldListR = [ 56 [ 'L', 0, 0, 0, 8, "Form" ], 57 [ 'L', 0, 0, 2, 0, "First Name" ], 58 [ 'F', 1, 15, 2, 12, "F Name" ], 59 [ 'L', 0, 0, 3, 0, "Last Name" ], 60 [ 'F', 1, 15, 3, 12, "L Name" ], 61 [ 'L', 0, 0, 5, 8, "Form (pt 2)" ], 62 [ 'L', 0, 0, 7, 0, "# Tuits" ], 63 [ 'F', 1, 5, 7, 12, "Tuits" ], 64 [ 'L', 0, 0, 8, 0, "# Bleems" ], 65 [ 'F', 1, 5, 8, 12, "Bleems" ] 66 ]; 67 68 my @fieldRList; 69 70 foreach my $F (@{$fieldListR}) { 71 my $fieldR; 72 # This is a Perl reference to a scalar number variable. The 73 # number is the numerical equivalent (cast) of the C pointer to the 74 # executable-Curses FIELD object. The reference is blessed into 75 # package "Curses::Field", but don't confuse it with a Perl 76 # object. 77 78 if ($F->[0] eq 'L') { 79 $fieldR = new_field(1, length($F->[5]), $F->[3], $F->[4], 0, 0); 80 if ($$fieldR eq '') { 81 fatal("new_field $F->[5] failed"); 82 } 83 set_field_buffer($fieldR, 0, $F->[5]); 84 field_opts_off($fieldR, O_ACTIVE); 85 field_opts_off($fieldR, O_EDIT); 86 } elsif ($F->[0] eq 'F') { 87 $fieldR = new_field($F->[1], $F->[2], $F->[3], $F->[4], 0, 0); 88 if ($$fieldR eq '') { 89 fatal("new_field $F->[5] failed"); 90 } 91 if ($F->[5] eq "Tuits") { 92 set_field_buffer($fieldR, 0, $F->[5]); 93 } 94 set_field_back($fieldR, A_UNDERLINE); 95 } 96 97 push(@fieldRList, $fieldR); 98 } 99 return @fieldRList; 100} 101 102 103 104sub interpretForm($$$) { 105 106 my ($cFieldRListR, $firstNameR, $lastNameR) = @_; 107 108 $$firstNameR = field_buffer($cFieldRListR->[2], 0); 109 $$lastNameR = field_buffer($cFieldRListR->[4], 0); 110} 111 112 113 114sub demo($$) { 115 116 my ($firstNameR, $lastNameR) = @_; 117 118 noecho(); 119 120 eval { new_form() }; 121 if ($@ =~ m{not defined in your Curses library}) { 122 print STDERR "Curses was not compiled with form function.\n"; 123 exit 1; 124 } 125 126 my @cFieldRList = makeFields(); 127 128 # Believe it or not, we have to pass to new_form() a string whose 129 # representation in memory is a C array of pointers to C field objects. 130 # Don't try to understand it; just copy this magic pack code. 131 132 # The argument is a string whose ASCII encoding is an array of C 133 # pointers. Each pointer is to a FIELD object of the 134 # executable-Curses library, except the last is NULL to mark the 135 # end of the list. For example, assume there are two fields and 136 # the executable-Curses library represents them with FIELD objects 137 # whose addresses (pointers) are 0x11223344 and 0x0004080C. The 138 # argument to Curses::new_form() is a 12 character string whose 139 # ASCII encoding is 0x112233440004080C00000000 . 140 141 my @cFieldList; 142 foreach my $cFieldR (@cFieldRList) { 143 push(@cFieldList, ${$cFieldR}); 144 } 145 146 push(@cFieldList, 0); 147 148 my $fieldListFormArg = pack('L!*', @cFieldList); 149 150 my $formR = new_form($fieldListFormArg); 151 if (${$formR} eq '') { 152 fatal("new_form failed"); 153 } 154 155 # Don't under any circumstance destroy $itemListMenuArg while the menu 156 # object still exists, since the C menu object actually points to the 157 # memory that backs $itemListMenuArg. 158 159 # And don't destroy @cItemList or @cItemRList either while the menu object 160 # still exists, because they are backed by memory that the C menu object 161 # references as well. 162 163 my $rows; 164 my $cols; 165 166 scale_form($formR, $rows, $cols); 167 168 my $fwinR = newwin($rows + 2, $cols + 4, 4, 0); 169 my $fsubR = derwin($fwinR, $rows, $cols, 1, 2); 170 171 set_form_win($formR, $fwinR); 172 set_form_sub($formR, $fsubR); 173 174 box($fwinR, 0, 0); 175 keypad($fwinR, 1); 176 177 post_form($formR); 178 179 addstr(0, 0, "Use KEY_UP/KEY_DOWN/KEY_PPAGE/KEY_NPAGE to navigate"); 180 addstr(1, 0, "Press 'ENTER' to select item, or 'F1' to exit"); 181 addstr(2, 0, "Other alphanumeric characters will enter data"); 182 refresh(); 183 184 driveForm($fwinR, $formR); 185 186 interpretForm(\@cFieldRList, $firstNameR, $lastNameR); 187 188 unpost_form($formR); 189 delwin($fwinR); 190 free_form($formR); 191 map { free_field($_) } @cFieldRList; 192} 193 194 195 196############################################################################## 197# MAINLINE 198############################################################################## 199 200initscr(); 201 202# The eval makes sure if it croaks, we have a chance to restore the 203# terminal. 204 205my ($firstName, $lastName); 206 207eval { demo(\$firstName, \$lastName) }; 208 209endwin(); 210 211if ($@) { 212 print STDERR "Failed. $@\n"; 213 exit(1); 214} 215 216print "You entered '$firstName' for First Name and " 217 . "'$lastName' for Last Name\n"; 218 219exit(0); 220