1 #!/usr/perl5/bin/perl
2 #
3 # Copyright (c) 2003, Oracle and/or its affiliates. All rights reserved.
4 #
5
6 #
7 # This script is a stress test for ::Exacct and libexacct.
8 # See README for details.
9 #
10
11 use strict;
12 use warnings;
13 use blib;
14 use POSIX qw(:sys_wait_h);
15
16 use Sun::Solaris::Exacct qw(:ALL);
17 use Sun::Solaris::Exacct::Catalog qw(:ALL);
18 use Sun::Solaris::Exacct::Object qw(:ALL);
19 use Sun::Solaris::Exacct::File qw(:ALL);
20 use Fcntl;
21
22 our $exit = 0;
23 our $ono = 1;
24 our $maxono = 1000; # max = 16777216 (2^24)
25
26 #
27 # Dump an object.
28 #
29 sub dump_object
30 {
31 my ($obj, $fh, $indent) = @_;
32 $fh ||= \*STDOUT;
33 $indent ||= 0;
34 my @cat = $obj->catalog()->value();
35 my $istr = ' ' x $indent;
36
37 if ($obj->type() == &EO_ITEM) {
38 printf $fh ("%sITEM\n%s Catalog = %s|%s|%d\n",
39 $istr, $istr, @cat);
40 $indent++;
41 my $val = $obj->value();
42 if (ref($val)) {
43 dump_object($val, $fh, $indent);
44 } else {
45 printf $fh ("%s Value = %s\n", $istr, $val);
46 }
47 } else {
48 printf $fh ("%sGROUP\n%s Catalog = %s|%s|%d\n",
49 $istr, $istr, @cat);
50 $indent++;
51 foreach my $val ($obj->value()) {
52 dump_object($val, $fh, $indent);
53 }
54 printf $fh ("%sENDGROUP\n", $istr);
55 }
56 }
57
58 #
59 # Dump a list of objects.
60 #
61 sub dump_objects
62 {
63 my ($fh, $objs) = @_;
64 foreach my $o (@$objs) {
65 dump_object($o, $fh);
66 }
67 }
68
69 #
70 # Build up a set of random objects.
71 #
72 sub gen_objs
73 {
74 my ($nobjs, $embed) = @_;
75 $nobjs += $ono;
76 $embed ||= 0;
77 my @objs;
78 while ($ono < $nobjs) {
79 my $rt = int(rand(9)) + 1;
80 $rt = 15 if ($rt >= 9); # Group.
81 $rt <<= 28;
82 if ($rt == &EXT_UINT8) {
83 push(@objs, ea_new_item($rt | $ono++, 8));
84 } elsif ($rt == &EXT_UINT16) {
85 push(@objs, ea_new_item($rt | $ono++, 16));
86 } elsif ($rt == &EXT_UINT32) {
87 push(@objs, ea_new_item($rt | $ono++, 32));
88 } elsif ($rt == &EXT_UINT64) {
89 push(@objs, ea_new_item($rt | $ono++, 64));
90 } elsif ($rt == &EXT_DOUBLE) {
91 push(@objs, ea_new_item($rt | $ono++,
92 123456789.123456789));
93 } elsif ($rt == &EXT_STRING) {
94 push(@objs, ea_new_item($rt | $ono++, "string"));
95 } elsif ($rt == &EXT_EXACCT_OBJECT) {
96 my $o = $ono++;
97 my $i = int(rand($nobjs - $ono)) + 1;
98 push(@objs, ea_new_item($rt | $o, gen_objs($i, 1)));
99 } elsif ($rt == &EXT_RAW) {
100 push(@objs, ea_new_item($rt | $ono++, "RAWrawRAW"));
101 } elsif ($rt == &EXT_GROUP) {
102 my $o = $ono++;
103 my $i = int(rand($nobjs - $ono + 1));
104 push(@objs, ea_new_group($rt | $o, gen_objs($i)));
105 }
106
107 # If for an embedded object, just return 1 object.
108 last if ($embed);
109 }
110 return(@objs);
111 }
112
113 #
114 # Main routine.
115 #
116 $| = 1;
117 $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $exit = 1; };
118 my $iters = 0;
119 while (! $exit) {
120 print(".");
121
122 # Generate and output some random records.
123 my $f = ea_new_file("/tmp/wr.$$", &O_RDWR | &O_CREAT | &O_TRUNC)
124 || die("\ncreate /tmp/wr.$$ failed: ", ea_error_str(), "\n");
125 my @outobjs = gen_objs($maxono);
126 $f->write(@outobjs);
127 $f = undef;
128 open($f, ">/tmp/wr1.$$") || die("\nopen /tmp/wr1.$$ failed: $!\n");
129 dump_objects($f, \@outobjs);
130 close($f);
131 @outobjs = ();
132
133 # Scan the file forwards with next.
134 $f = ea_new_file("/tmp/wr.$$", &O_RDONLY)
135 || die("\nopen /tmp/wr.$$ failed: ", ea_error_str(), "\n");
136 while ($f->next()) {
137 ;
138 }
139 die("\nnext /tmp/wr.$$ failed: ", ea_error_str(), "\n")
140 unless (ea_error() == EXR_EOF);
141 $f = undef;
142
143 # Scan the file backwards with previous.
144 $f = ea_new_file("/tmp/wr.$$", &O_RDONLY, aflags => &EO_TAIL)
145 || die("\nopen /tmp/wr.$$ failed: ", ea_error_str(), "\n");
146 while ($f->previous()) {
147 ;
148 }
149 die("\nprevious /tmp/wr.$$ failed: ", ea_error_str(), "\n")
150 unless (ea_error() == EXR_EOF);
151 $f = undef;
152
153 # Read the file forwards with get.
154 my @inobjs = ();
155 $f = ea_new_file("/tmp/wr.$$", &O_RDONLY)
156 || die("\nopen /tmp/wr.$$ failed: ", ea_error_str(), "\n");
157 while (my $obj = $f->get()) {
158 push(@inobjs, $obj);
159 }
160 die("\nget /tmp/wr.$$ failed: ", ea_error_str(), "\n")
161 unless (ea_error() == EXR_EOF);
162 $f = undef;
163
164 # Dump the objects and compare with original.
165 open($f, ">/tmp/wr2.$$") || die("\nopen /tmp/wr2.$$ failed: $!\n");
166 dump_objects($f, \@inobjs);
167 close($f);
168 if (system("cmp -s /tmp/wr1.$$ /tmp/wr2.$$") != 0) {
169 die("\nget cmp failed /tmp/wr2.$$\n");
170 }
171
172 # Read the file forwards with next and get.
173 @inobjs = ();
174 $f = ea_new_file("/tmp/wr.$$", &O_RDONLY)
175 || die("\nopen /tmp/wr.$$ failed: ", ea_error_str(), "\n");
176 while ($f->next()) {
177 my $obj = $f->get();
178 push(@inobjs, $obj);
179 }
180 die("\nnext/get /tmp/wr.$$ failed: ", ea_error_str(), "\n")
181 unless (ea_error() == EXR_EOF);
182 $f = undef;
183
184 # Dump the objects and compare with original.
185 open($f, ">/tmp/wr2.$$") || die("\nopen /tmp/wr2.$$ failed: $!\n");
186 dump_objects($f, \@inobjs);
187 close($f);
188 if (system("cmp -s /tmp/wr1.$$ /tmp/wr2.$$") != 0) {
189 die("\nnext/get cmp failed /tmp/wr2.$$\n");
190 }
191
192 # Read the file backwards with previous and get.
193 @inobjs = ();
194 $f = ea_new_file("/tmp/wr.$$", &O_RDONLY, aflags => &EO_TAIL)
195 || die("\nopen /tmp/wr.$$ failed: ", ea_error_str(), "\n");
196 while ($f->previous()) {
197 my $obj = $f->get();
198 $f->previous();
199 unshift(@inobjs, $obj);
200 }
201 die("\nprevious/get /tmp/wr.$$ failed: ", ea_error_str(), "\n")
202 unless (ea_error() == EXR_EOF);
203 $f = undef;
204
205 # Dump the objects and compare with original.
206 open($f, ">/tmp/wr2.$$") || die("\nopen /tmp/wr2.$$ failed: $!\n");
207 dump_objects($f, \@inobjs);
208 close($f);
209 if (system("cmp -s /tmp/wr1.$$ /tmp/wr2.$$") != 0) {
210 die("\nprevious/get cmp failed /tmp/wr2.$$\n");
211 }
212
213 # Run randtest on the file.
214 foreach my $sz (qw(5 10 50 100)) {
215 my $s = system ("./randtest 1000 $sz /tmp/wr.$$") >> 8;
216 if ($s == 2) {
217 $exit = 1;
218 } elsif ($s != 0) {
219 die("randtest 1000 $sz /tmp/wr.$$ failed $s\n");
220 }
221 }
222
223 $iters++;
224 }
225 unlink("/tmp/wr.$$", "/tmp/wr1.$$", "/tmp/wr2.$$") ||
226 die("\nCan't cleanup: $!\n");
227 print("\n$iters iterations completed\n");