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