Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # ========== Copyright Header Begin ========================================== |
2 | # | |
3 | # OpenSPARC T2 Processor File: Output.pm | |
4 | # Copyright (C) 1995-2007 Sun Microsystems, Inc. All Rights Reserved | |
5 | # 4150 Network Circle, Santa Clara, California 95054, U.S.A. | |
6 | # | |
7 | # * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. | |
8 | # | |
9 | # This program is free software; you can redistribute it and/or modify | |
10 | # it under the terms of the GNU General Public License as published by | |
11 | # the Free Software Foundation; version 2 of the License. | |
12 | # | |
13 | # This program is distributed in the hope that it will be useful, | |
14 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | # GNU General Public License for more details. | |
17 | # | |
18 | # You should have received a copy of the GNU General Public License | |
19 | # along with this program; if not, write to the Free Software | |
20 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
21 | # | |
22 | # For the avoidance of doubt, and except that if any non-GPL license | |
23 | # choice is available it will apply instead, Sun elects to use only | |
24 | # the General Public License version 2 (GPLv2) at this time for any | |
25 | # software where a choice of GPL license versions is made | |
26 | # available with the language indicating that GPLv2 or any later version | |
27 | # may be used, or where a choice of which version of the GPL is applied is | |
28 | # otherwise unspecified. | |
29 | # | |
30 | # Please contact Sun Microsystems, Inc., 4150 Network Circle, Santa Clara, | |
31 | # CA 95054 USA or visit www.sun.com if you need additional information or | |
32 | # have any questions. | |
33 | # | |
34 | # ========== Copyright Header End ============================================ | |
35 | package AnalyzeDiag::Output; | |
36 | ||
37 | use strict; | |
38 | use warnings; | |
39 | ||
40 | use Carp; | |
41 | ||
42 | require Exporter; | |
43 | ||
44 | our @ISA = qw(Exporter); | |
45 | our @EXPORT = qw(chat debug script_warning script_die script_say verbose | |
46 | diag_ok diag_is diag_is_numeric | |
47 | script_exit | |
48 | ); | |
49 | ||
50 | our $VERBOSE = 1; | |
51 | our $EXIT_VAL = 0; | |
52 | ||
53 | ############################################################################### | |
54 | ||
55 | sub verbose { | |
56 | my $verbose = shift; | |
57 | $VERBOSE = $verbose if defined $verbose; | |
58 | return $VERBOSE; | |
59 | } | |
60 | ||
61 | ############################################################################### | |
62 | ||
63 | sub _add_prefix { | |
64 | my $prefix = shift; | |
65 | my @text = @_; | |
66 | ||
67 | ||
68 | my @lines; | |
69 | foreach my $textline (@text) { | |
70 | push @lines, split /\n/, $textline; | |
71 | } | |
72 | @lines = map { "$prefix$_" } @lines; | |
73 | my $return = join "\n", @lines; | |
74 | $return .= "\n"; | |
75 | return $return; | |
76 | } | |
77 | ||
78 | ############################################################################### | |
79 | ||
80 | sub chat { | |
81 | my @msg = @_; | |
82 | return unless $VERBOSE; | |
83 | my $text = _add_prefix("AnalyzeDiag: ", @msg); | |
84 | print $text; | |
85 | } | |
86 | ||
87 | ############################################################################### | |
88 | ||
89 | sub debug { | |
90 | my @msg = @_; | |
91 | return unless $VERBOSE >= 2; | |
92 | my $text = _add_prefix("AnalyzeDiag: ", @msg); | |
93 | print $text; | |
94 | ||
95 | } | |
96 | ||
97 | ############################################################################### | |
98 | ||
99 | sub script_warning { | |
100 | my @msg = @_; | |
101 | my $text = _add_prefix("AnalyzeDiag: WARNING:", @msg); | |
102 | print $text; | |
103 | } | |
104 | ||
105 | ############################################################################### | |
106 | ||
107 | sub script_die { | |
108 | my @msg = @_; | |
109 | my $backtrace = Carp::longmess(); | |
110 | my $text = _add_prefix("AnalyzeDiag: ", @msg); | |
111 | print $text; | |
112 | ||
113 | print "---------\n"; | |
114 | ||
115 | my $bt = _add_prefix("BACKTRACE: ", $backtrace); | |
116 | print $bt; | |
117 | ||
118 | exit(2); | |
119 | } | |
120 | ||
121 | ############################################################################### | |
122 | ||
123 | sub script_say { | |
124 | my @msg = @_; | |
125 | my $text = _add_prefix("AnalyzeDiag: ", @msg); | |
126 | print $text; | |
127 | } | |
128 | ||
129 | ############################################################################### | |
130 | ||
131 | sub script_exit { | |
132 | script_say "Exiting with status $EXIT_VAL.\n"; | |
133 | exit $EXIT_VAL; | |
134 | } | |
135 | ||
136 | ############################################################################### | |
137 | ||
138 | sub diag_ok { | |
139 | my $test = shift; | |
140 | my $name = shift; | |
141 | ||
142 | $name = "Test='$test'" unless defined $name; | |
143 | ||
144 | if($test) { | |
145 | script_say "Performance Test: PASS: $name\n"; | |
146 | } else { | |
147 | script_say "Performance Test: FAIL: $name\n"; | |
148 | $EXIT_VAL ||= 1; | |
149 | } | |
150 | ||
151 | # bool test to 1/0 | |
152 | return 1 if $test; | |
153 | return 0; | |
154 | } | |
155 | ||
156 | ############################################################################### | |
157 | ||
158 | sub diag_is { | |
159 | my $got = shift; | |
160 | my $expect = shift; | |
161 | my $name = shift; | |
162 | ||
163 | $name = "Test='$got'=='$expect'" unless defined $name; | |
164 | ||
165 | if($got eq $expect) { | |
166 | script_say "Performance Test: PASS: $name\n"; | |
167 | } else { | |
168 | script_say "Performance Test: FAIL: $name\n", | |
169 | " Got '$got', Expected '$expect'\n"; | |
170 | $EXIT_VAL ||= 1; | |
171 | } | |
172 | ||
173 | return 1 if $got eq $expect; | |
174 | return 0; | |
175 | } | |
176 | ||
177 | ############################################################################### | |
178 | ||
179 | sub diag_is_numeric { | |
180 | my $got = shift; | |
181 | my $expect = shift; | |
182 | my $name = shift; | |
183 | my $tolerance = shift; | |
184 | ||
185 | $tolerance = 0 unless defined $tolerance; | |
186 | $name = "Test='$got'=='$expect' (tolerance=$tolerance)" unless defined $name; | |
187 | ||
188 | my $booltest = ( $got >= ($expect - $tolerance) && | |
189 | $got <= ($expect + $tolerance)); | |
190 | ||
191 | if($booltest) { | |
192 | my $str = ($got == $expect) ? "got expected $got" : | |
193 | "got $got, exp $expect, tol $tolerance"; | |
194 | script_say "Performance Test: PASS: $name ($str)\n"; | |
195 | } else { | |
196 | script_say "Performance Test: FAIL: $name\n", | |
197 | " Got '$got', Expected '$expect' (tolerance=$tolerance)\n"; | |
198 | $EXIT_VAL ||= 1; | |
199 | } | |
200 | ||
201 | return $booltest; | |
202 | } | |
203 | ||
204 | ############################################################################### | |
205 | 1; |