| 1 | # ========== Copyright Header Begin ========================================== |
| 2 | # |
| 3 | # OpenSPARC T2 Processor File: Command.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 | # -*- perl -*- |
| 36 | |
| 37 | package Midas::Command; |
| 38 | use strict; |
| 39 | |
| 40 | use Getopt::Long; |
| 41 | use File::Spec; |
| 42 | use File::Basename; |
| 43 | use File::Spec; |
| 44 | use Cwd; |
| 45 | |
| 46 | use Midas::Error; |
| 47 | use Midas::Globals; |
| 48 | |
| 49 | use TRELoad 'BitFieldTie'; |
| 50 | |
| 51 | require Exporter; |
| 52 | |
| 53 | our @ISA = qw(Exporter); |
| 54 | our @EXPORT = qw(run_command chat fatal banner string2bf hexstring2bf |
| 55 | verbose opt_n |
| 56 | ); |
| 57 | |
| 58 | our $Prg = basename $0; |
| 59 | #our %opt = ( verbose => 1 ); |
| 60 | our $Verbose = 1; |
| 61 | our $N = 0; |
| 62 | |
| 63 | ############################################################################## |
| 64 | |
| 65 | sub verbose { |
| 66 | return $$Verbose if ref $Verbose; |
| 67 | return $Verbose; |
| 68 | } |
| 69 | |
| 70 | ############################################################################## |
| 71 | |
| 72 | sub opt_n { |
| 73 | return $$N if ref $N; |
| 74 | return $N; |
| 75 | } |
| 76 | |
| 77 | ############################################################################## |
| 78 | |
| 79 | sub fatal { |
| 80 | my $msg = shift; |
| 81 | my $code = shift; |
| 82 | |
| 83 | my $obj = Midas::Error->throw($msg, $code); |
| 84 | |
| 85 | die $obj; |
| 86 | } |
| 87 | |
| 88 | ############################################################################## |
| 89 | |
| 90 | sub chat { |
| 91 | my $msgs = shift; |
| 92 | my $level = shift; |
| 93 | |
| 94 | $level = 1 unless defined $level; |
| 95 | return unless verbose >= $level; |
| 96 | |
| 97 | local($_); |
| 98 | my @lines = split /\n/, "$msgs"; |
| 99 | my $string = "$Prg: " . (join "\n$Prg: $_", @lines); |
| 100 | |
| 101 | print "$string\n"; |
| 102 | } |
| 103 | |
| 104 | ############################################################################## |
| 105 | |
| 106 | sub banner { |
| 107 | my @lines = @_; |
| 108 | |
| 109 | chat "###########################################################\n", 2; |
| 110 | |
| 111 | foreach my $line (@lines) { |
| 112 | print "$Prg: ## $line\n" if verbose > 0; |
| 113 | } |
| 114 | |
| 115 | chat "###########################################################\n", 2; |
| 116 | } |
| 117 | |
| 118 | ############################################################################## |
| 119 | |
| 120 | sub configure { |
| 121 | my %args = @_; |
| 122 | |
| 123 | foreach my $key (keys %args) { |
| 124 | if($key eq 'verbose') { |
| 125 | $Verbose = $args{$key}; |
| 126 | } elsif($key eq 'n') { |
| 127 | $N = $args{$key}; |
| 128 | } else { |
| 129 | fatal "Midas::Command does not recongnize configuration option ". |
| 130 | "$key.\n"; |
| 131 | } |
| 132 | } |
| 133 | |
| 134 | return ( verbose => $Verbose, |
| 135 | n => $N, |
| 136 | ); |
| 137 | |
| 138 | } |
| 139 | |
| 140 | ############################################################################## |
| 141 | |
| 142 | sub run_command { |
| 143 | my $command = shift; |
| 144 | my @flags = @_; |
| 145 | |
| 146 | my %cmd_opt = ( |
| 147 | verbose => 1, |
| 148 | fatal => 1, |
| 149 | errcode => M_CMDFAIL, |
| 150 | pass_errcode => 0, |
| 151 | ); |
| 152 | my @options = qw( verbose=i fatal! errcode=i pass_errcode! ); |
| 153 | local (@ARGV) = @flags; |
| 154 | Getopt::Long::Configure('no_pass_through'); |
| 155 | GetOptions(\%cmd_opt, @options) or |
| 156 | fatal "Cannot parse flags to run_command: @flags\n"; |
| 157 | |
| 158 | if(verbose >= $cmd_opt{verbose}) { |
| 159 | print "$Prg: $command\n"; |
| 160 | } |
| 161 | my $status = 0; |
| 162 | $status = system($command) unless opt_n; |
| 163 | if($cmd_opt{fatal} and $status) { |
| 164 | my $exit = $status >> 8; |
| 165 | my $sig = $status & 127; |
| 166 | my $core = $status & 128; |
| 167 | my $core_msg = $core ? "Dumped core." : ""; |
| 168 | |
| 169 | if($sig) { |
| 170 | fatal "Command \"$command\" died via signal $sig. $core_msg\n", |
| 171 | $cmd_opt{errcode}; |
| 172 | } |
| 173 | |
| 174 | if($cmd_opt{pass_errcode} and exists $ERRCODES{$exit}) { |
| 175 | fatal "Command \"$command\" failed. $core_msg\n", $exit; |
| 176 | } else { |
| 177 | fatal "Command \"$command\" failed with status $exit. $core_msg\n", |
| 178 | $cmd_opt{errcode}; |
| 179 | } |
| 180 | } |
| 181 | } |
| 182 | |
| 183 | ############################################################################## |
| 184 | |
| 185 | sub string2bf { |
| 186 | my $string = shift; |
| 187 | my $width = shift; |
| 188 | |
| 189 | fatal "Cannot run string2bf without a width argument!\n", M_CODE |
| 190 | unless defined $width; |
| 191 | |
| 192 | my $ishex = 0; |
| 193 | if($string =~ /^\s*0[xX]/ or ref($string) or $CONFIG{default_radix} eq 'hex') |
| 194 | { |
| 195 | $ishex = 1; |
| 196 | # Test for overflow |
| 197 | (my $mystring = $string) =~ s/^\s*0[xX]//; |
| 198 | $mystring =~ s/\s*$//; |
| 199 | my $max_digits = int($width / 4); |
| 200 | $max_digits++ if (($max_digits) * 4 != $width); |
| 201 | |
| 202 | if(length $mystring > $max_digits) { |
| 203 | my $difference = (length $mystring) - $max_digits; |
| 204 | my $leader = substr($mystring, 0, $difference); |
| 205 | return "Hex overflow: \"$string\" won't fit in $width bits!\n" |
| 206 | unless $leader eq ('0' x $difference); |
| 207 | } |
| 208 | } else { |
| 209 | |
| 210 | my $max_bf = BitFieldTie->new(65, "1"); |
| 211 | $max_bf->left_shift($width); |
| 212 | |
| 213 | my $test_bf; |
| 214 | eval { |
| 215 | $test_bf = BitFieldTie->new_dec(65, $string); |
| 216 | }; |
| 217 | if(not $@) { |
| 218 | if($test_bf->ucompare($max_bf) >= 0) { |
| 219 | return "Dec Overflow: \"$string\" won't fit in $width bits!\n"; |
| 220 | } |
| 221 | } |
| 222 | |
| 223 | } |
| 224 | |
| 225 | |
| 226 | my $bf; |
| 227 | eval { |
| 228 | if($ishex) { |
| 229 | $bf = BitFieldTie->new($width, $string); |
| 230 | } else { |
| 231 | $bf = BitFieldTie->new_dec($width, $string); |
| 232 | } |
| 233 | }; |
| 234 | if($@) { |
| 235 | return $@; |
| 236 | } else { |
| 237 | return $bf; |
| 238 | } |
| 239 | } |
| 240 | |
| 241 | ############################################################################## |
| 242 | |
| 243 | sub hexstring2bf { |
| 244 | my $string = shift; |
| 245 | my $width = shift; |
| 246 | |
| 247 | $string = "0x$string" unless $string =~ /^\s*0[xX]/; |
| 248 | return string2bf($string, $width); |
| 249 | } |
| 250 | |
| 251 | ############################################################################## |
| 252 | 1; |