]>
Commit | Line | Data |
---|---|---|
e38f8ec4 TC |
1 | #!/usr/bin/perl -w |
2 | # $Id: 01_array.t,v 1.1 2004/09/04 22:50:38 rcaputo Exp $ | |
3 | ||
4 | # Tests basic queue operations. | |
5 | # copied from the POE distribution and modified to use | |
6 | # POE::XS::Queue::Array instead of POE::Queue::Array. | |
7 | # | |
8 | # modified a couple of tests to use is_deeply() instead of ok(eq_array ...) | |
9 | # during debugging. | |
10 | ||
11 | use strict; | |
12 | ||
13 | use lib qw(./mylib); | |
14 | ||
a603f2ce | 15 | use Test::More tests => 2048; |
e38f8ec4 TC |
16 | |
17 | sub POE::Kernel::ASSERT_DEFAULT () { 1 } | |
18 | sub POE::Kernel::TRACE_DEFAULT () { 1 } | |
19 | sub POE::Kernel::TRACE_FILENAME () { "./test-output.err" } | |
20 | ||
21 | use POSIX qw(EPERM ESRCH); | |
22 | ||
23 | BEGIN { use_ok("POE::XS::Queue::Array") } | |
24 | ||
25 | my $q = POE::XS::Queue::Array->new(); | |
26 | ||
a603f2ce TC |
27 | isa_ok($q, 'POE::Queue'); |
28 | ||
e38f8ec4 TC |
29 | ok($q->get_item_count == 0, "queue begins empty"); |
30 | ok(!defined($q->dequeue_next), "can't dequeue from empty queue"); | |
31 | ||
32 | ok($q->enqueue(1, "one") == 1, "first enqueue has id 1"); | |
33 | ok($q->enqueue(3, "tre") == 2, "second enqueue has id 2"); | |
34 | ok($q->enqueue(2, "two") == 3, "third enqueue has id 3"); | |
35 | ||
36 | is_deeply( | |
37 | [$q->dequeue_next()], [1, 1, "one"], | |
38 | "event one dequeued correctly" | |
39 | ); | |
40 | ||
41 | is_deeply( | |
42 | [$q->dequeue_next()], [2, 3, "two"], | |
43 | "event two dequeued correctly" | |
44 | ); | |
45 | ||
46 | ok( | |
47 | eq_array( [$q->dequeue_next()], [3, 2, "tre"] ), | |
48 | "event three dequeued correctly" | |
49 | ); | |
50 | ||
51 | ok( | |
52 | eq_array( [$q->dequeue_next()], [] ), | |
53 | "empty queue marker dequeued correctly" | |
54 | ); | |
55 | ||
56 | { my @events = ( | |
57 | [ a => 1 ], | |
58 | [ c => 3 ], | |
59 | [ e => 5 ], | |
60 | [ b => 2 ], | |
61 | [ d => 4 ], | |
62 | ); | |
63 | ||
64 | my $base_event_id = 4; | |
65 | enqueue_events(\@events, $base_event_id); | |
66 | } | |
67 | ||
68 | # Not constants. | |
69 | sub always_ok { 1 } | |
70 | sub never_ok { 0 } | |
71 | ||
72 | ok( | |
73 | eq_array( [$q->remove_item(7, \&always_ok)], [2, 7, "b"] ), | |
74 | "removed event b by its ID" | |
75 | ); | |
76 | ||
77 | ok( | |
78 | eq_array( [$q->remove_item(5, \&always_ok)], [3, 5, "c"] ), | |
79 | "removed event c by its ID" | |
80 | ); | |
81 | ||
82 | ok( | |
83 | eq_array( [$q->remove_item(8, \&always_ok)], [4, 8, "d"] ), | |
84 | "removed event d by its ID" | |
85 | ); | |
86 | ||
87 | $! = 0; | |
88 | ok( | |
89 | ( eq_array( [$q->remove_item(6, \&never_ok )], [] ) && | |
90 | $! == EPERM | |
91 | ), | |
92 | "didn't have permission to remove event e" | |
93 | ); | |
94 | ||
95 | $! = 0; | |
96 | ok( | |
97 | ( eq_array( [$q->remove_item(8, \&always_ok)], [] ) && | |
98 | $! == ESRCH | |
99 | ), | |
100 | "couldn't remove nonexistent event d" | |
101 | ); | |
102 | ||
103 | ok( | |
104 | eq_array( [$q->dequeue_next()], [1, 4, "a"] ), | |
105 | "dequeued event a correctly" | |
106 | ); | |
107 | ||
108 | ok( | |
109 | eq_array( [$q->dequeue_next()], [5, 6, "e"] ), | |
110 | "dequeued event e correctly" | |
111 | ); | |
112 | ||
113 | ok( | |
114 | eq_array( [$q->dequeue_next()], [] ), | |
115 | "empty queue marker dequeued correctly" | |
116 | ); | |
117 | ||
118 | { my @events = ( | |
119 | [ a => 1 ], | |
120 | [ c => 3 ], | |
121 | [ e => 5 ], | |
122 | [ b => 2 ], | |
123 | [ d => 4 ], | |
124 | [ f => 6 ], | |
125 | ); | |
126 | ||
127 | my $base_event_id = 9; | |
128 | enqueue_events(\@events, $base_event_id); | |
129 | } | |
130 | ||
131 | ok($q->get_item_count() == 6, "queue contains six events"); | |
132 | ||
133 | sub odd_letters { $_[0] =~ /[ace]/ } | |
134 | sub even_letters { $_[0] =~ /[bdf]/ } | |
135 | ||
136 | { my @items = $q->remove_items(\&odd_letters, 3); | |
137 | my @target = ( | |
138 | [ 1, 9, "a" ], | |
139 | [ 3, 10, "c" ], | |
140 | [ 5, 11, "e" ], | |
141 | ); | |
142 | ||
143 | ok(eq_array(\@items, \@target), "removed odd letters from queue"); | |
144 | ok($q->get_item_count() == 3, "leaving three events"); | |
145 | } | |
146 | ||
147 | { my @items = $q->remove_items(\&odd_letters, 3); | |
148 | my @target; | |
149 | ||
150 | ok(eq_array(\@items, \@target), "no more odd letters to remove"); | |
151 | } | |
152 | ||
153 | { my @items = $q->remove_items(\&even_letters, 3); | |
154 | my @target = ( | |
155 | [ 2, 12, "b" ], | |
156 | [ 4, 13, "d" ], | |
157 | [ 6, 14, "f" ], | |
158 | ); | |
159 | ||
160 | is_deeply(\@items, \@target, "removed even letters from queue"); | |
161 | ok($q->get_item_count() == 0, "leaving the queue empty"); | |
162 | } | |
163 | ||
164 | { my @events = ( | |
165 | [ a => 10 ], | |
166 | [ b => 20 ], | |
167 | [ c => 30 ], | |
168 | [ d => 40 ], | |
169 | [ e => 50 ], | |
170 | [ f => 60 ], | |
171 | ); | |
172 | ||
173 | my $base_event_id = 15; | |
174 | enqueue_events(\@events, $base_event_id); | |
175 | } | |
176 | ||
177 | ok($q->get_item_count() == 6, "leaving six events in the queue"); | |
178 | ||
179 | { my @items = $q->peek_items(\&even_letters); | |
180 | my @target = ( | |
181 | [ 20, 16, "b" ], | |
182 | [ 40, 18, "d" ], | |
183 | [ 60, 20, "f" ], | |
184 | ); | |
185 | ||
186 | ok(eq_array(\@items, \@target), "found even letters in queue"); | |
187 | } | |
188 | ||
189 | ok( | |
190 | $q->adjust_priority(19, \&always_ok, -15) == 35, | |
191 | "adjusted event e priority by -15" | |
192 | ); | |
193 | ||
194 | ok( | |
195 | $q->adjust_priority(16, \&always_ok, +15) == 35, | |
196 | "adjusted event b priority by +15" | |
197 | ); | |
198 | ||
199 | { my @items = $q->remove_items(\&always_ok); | |
200 | my @target = ( | |
201 | [ 10, 15, "a" ], | |
202 | [ 30, 17, "c" ], | |
203 | [ 35, 19, "e" ], # e got there first | |
204 | [ 35, 16, "b" ], # b got there second | |
205 | [ 40, 18, "d" ], | |
206 | [ 60, 20, "f" ], | |
207 | ); | |
208 | ||
209 | ok(eq_array(\@items, \@target), "colliding priorities are FIFO"); | |
210 | } | |
211 | ||
212 | ok($q->get_item_count() == 0, "full queue removal leaves zero events"); | |
213 | ||
214 | ### Large Queue Tests. The only functions that use large queues are | |
215 | ### enqueue(), adjust_priority(), and set_priority(). Large queues | |
216 | ### are over ~500 elements. | |
217 | ||
218 | # Generate a list of events in random priority order. | |
219 | ||
220 | sub shuffled_list { | |
221 | my $limit = shift() - 1; | |
222 | my @list = (0..$limit); | |
223 | my $i = @list; | |
224 | while (--$i) { | |
225 | my $j = int rand($i+1); | |
226 | @list[$i,$j] = @list[$j,$i]; | |
227 | } | |
228 | @list; | |
229 | } | |
230 | ||
231 | sub is_even { !($_[0] % 2) } | |
232 | sub is_odd { $_[0] % 2 } | |
233 | ||
234 | sub verify_queue { | |
235 | my $target_diff = shift; | |
236 | ||
237 | my $low_priority = -999999; | |
238 | ||
239 | while (my ($pri, $id, $item) = $q->dequeue_next()) { | |
240 | my $diff; | |
241 | if ($pri < 0) { | |
242 | $diff = $item - $pri; | |
243 | } | |
244 | else { | |
245 | $diff = $pri - $item; | |
246 | } | |
247 | ||
248 | ok( | |
249 | ($pri > $low_priority) && ($diff == $target_diff), | |
250 | "$item - $pri == $diff (should be $target_diff)" | |
251 | ); | |
252 | ||
253 | $low_priority = $pri; | |
254 | } | |
255 | } | |
256 | ||
257 | # Enqueue all the events, then adjust their priorities. The | |
258 | # even-numbered events have their priorities reduced by 1000; the odd | |
259 | # ones have their priorities increased by 1000. | |
260 | ||
261 | { my @ids; | |
262 | for my $major (shuffled_list(10)) { | |
263 | for my $minor (shuffled_list(100)) { | |
264 | my $priority = sprintf("%2d%02d", $major, $minor); | |
265 | push @ids, $q->enqueue($priority, $priority); | |
266 | } | |
267 | } | |
268 | ||
269 | foreach my $id (@ids) { $q->adjust_priority($id, \&is_even, -1000); } | |
270 | foreach my $id (@ids) { $q->adjust_priority($id, \&is_odd, 1000); } | |
271 | } | |
272 | ||
273 | # Verify that the queue remains in order, and that the adjusted | |
274 | # priorities are correct. | |
275 | ||
276 | print "!!!!!!!! 1\n"; | |
277 | verify_queue(1000); | |
278 | ||
279 | # Now set priorities to absolute values. The values are | |
280 | ||
281 | { my @id_recs; | |
282 | for my $major (shuffled_list(10)) { | |
283 | for my $minor (shuffled_list(100)) { | |
284 | my $priority = sprintf("%2d%02d", $major, $minor); | |
285 | push @id_recs, [ $q->enqueue($priority, $priority), $priority ]; | |
286 | } | |
287 | } | |
288 | ||
289 | foreach my $id_rec (@id_recs) { | |
290 | my ($id, $pri) = @$id_rec; | |
291 | $q->set_priority($id, \&is_even, $pri + 500); | |
292 | } | |
293 | ||
294 | foreach my $id_rec (@id_recs) { | |
295 | my ($id, $pri) = @$id_rec; | |
296 | $q->set_priority($id, \&is_odd, $pri + 500); | |
297 | } | |
298 | ||
299 | verify_queue(500); | |
300 | } | |
301 | ||
302 | ### Helper functions. | |
303 | ||
304 | sub enqueue_events { | |
305 | my ($events, $id) = @_; | |
306 | foreach (@$events) { | |
307 | my ($ev, $prio) = @$_; | |
308 | ok($q->enqueue($prio, $ev) == $id++, "enqueued event $ev correctly"); | |
309 | } | |
310 | } |