1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
#!./perl
#
# $Id: nocache.t,v 0.1.1.1 2001/03/20 10:34:50 ram Exp $
#
# Copyright (c) 2000-2001, Raphael Manfredi
#
# You may redistribute only under the terms of the Artistic License,
# as specified in the README file that comes with the distribution.
#
# HISTORY
# $Log: nocache.t,v $
# Revision 0.1.1.1 2001/03/20 10:34:50 ram
# patch3: updated all getargs() calls to new interface
#
# Revision 0.1 2001/03/01 18:37:19 ram
# Baseline for first alpha release.
#
# $EndLog$
#
print "1..17\n";
require 't/code.pl';
sub ok;
## same test case as t/cache.t, only without using c*() routines.
use Getargs::Long qw(ignorecase);
package BAR;
sub make { bless {}, shift }
package FOO;
@ISA = qw(BAR);
package main;
my $FOO = FOO->make;
my $BAR = BAR->make;
sub try {
my ($x, $y, $z, $t, $o, @other) = xgetargs(@_,
{
-strict => 0,
-extra => 0,
-inplace => 1,
},
'x' => ['i', 1],
-y => ['ARRAY', ['a', 'b']],
'z' => [],
't' => ['FOO', $FOO],
-o => 'i',
);
return ([$x, $y, $z, $t, $o], \@other, [@_]);
}
sub tryw {
my ($x, $y, $l, $z, $t) = xgetargs(@_,
'x' => ['i'], # integer, non-mandatory
'y' => ['ARRAY', ['a', 'b']], # Type, non-mandatory, default
'l' => [], # anything, non-mandatory
'z' => undef, # anything, mandatory
't' => 'BAR' # Type, mandatory
);
return ($x, $y, $z, $t);
}
my @a;
my ($x, $y, $z, $t);
my @other;
my @args;
@a = try(-o => -2, -t => $FOO, -Other => 2, 3);
($x, $y, $z, $t, $o) = @{$a[0]};
ok 1, $x == 1;
ok 2, ref $y eq 'ARRAY' && $y->[0] eq 'a';
ok 3, !defined $z;
ok 4, ref $t eq 'FOO';
ok 5, $o == -2;
@other = @{$a[1]};
ok 6, @other == 0;
@args = @{$a[2]};
ok 7, @args == 4;
ok 8, "@args" eq "-Other 2 ONE 3";
eval { try(-t => $FOO) };
ok 9, $@ =~ /\bargument 'o' missing\b/;
@a = try(-o => 1, -z => 'z', y => [], x => 5);
($x, $y, $z, $t, $o) = @{$a[0]};
ok 10, $x == 5;
ok 11, $z eq 'z';
ok 12, ref $y eq 'ARRAY' && @$y == 0;
eval { try(-o => undef, -z => 'z', y => [], x => 5) };
ok 13, $@ =~ /'o' cannot be undef\b/;
eval { tryw(-Z => 'BIG Z', y => [], x => 5) };
ok 14, $@ =~ /\bargument 't' missing\b/;
($x, $y, $z, $t) = tryw(-Z => 'BIG Z', y => [], x => 5, -t => $FOO);
ok 15, ref $t eq 'FOO';
eval { tryw(-T => 1, -Z => 'BIG Z', y => [], x => 5) };
ok 16, $@ =~ /'t' must be of type BAR but/;
eval {
tryw(-T => $BAR, -Z => 'BIG Z', y => [], x => 5,
-ExtraArg => 'extra-VALUE')
};
ok 17, $@ =~ /\bswitch: -extraarg\b/;
|