Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # ========== Copyright Header Begin ========================================== |
2 | # | |
3 | # OpenSPARC T2 Processor File: Paths.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::Paths; | |
38 | use strict; | |
39 | ||
40 | require Exporter; | |
41 | use Cwd; | |
42 | use File::Spec; | |
43 | ||
44 | ||
45 | use Midas::Command; | |
46 | use Midas::Error; | |
47 | ||
48 | our @ISA = qw(Exporter); | |
49 | our @EXPORT = qw(cd compact_path full_path | |
50 | path_to_build_file); | |
51 | ||
52 | our $Full_paths = 0; | |
53 | ||
54 | ############################################################################## | |
55 | ||
56 | # Note this function is not at all robust. Should work on that | |
57 | sub are_dirs_same { | |
58 | my $dir1 = shift; | |
59 | my $dir2 = shift; | |
60 | ||
61 | my $canon_dir1 = File::Spec->canonpath(File::Spec->rel2abs($dir1)); | |
62 | my $canon_dir2 = File::Spec->canonpath(File::Spec->rel2abs($dir2)); | |
63 | ||
64 | return ($canon_dir1 eq $canon_dir2); | |
65 | } | |
66 | ||
67 | ############################################################################## | |
68 | ||
69 | # ACTUALLY A CLASS METHOD | |
70 | sub pushd { | |
71 | my $class = shift; | |
72 | my $dir = shift; | |
73 | ||
74 | my $this = {}; | |
75 | bless $this, $class; | |
76 | ||
77 | if(not are_dirs_same($dir, getcwd)) { | |
78 | $this->{old} = getcwd; | |
79 | cd($dir); | |
80 | } | |
81 | ||
82 | return $this; | |
83 | } | |
84 | ||
85 | ############################################################################## | |
86 | ||
87 | # Not for public consumption | |
88 | sub popd { | |
89 | my $this = shift; | |
90 | return unless defined $this->{old}; | |
91 | cd(compact_path($this->{old})); | |
92 | } | |
93 | ||
94 | ############################################################################## | |
95 | ||
96 | # implicit call to popd | |
97 | sub DESTROY { | |
98 | my $this = shift; | |
99 | $this->popd(); | |
100 | } | |
101 | ||
102 | ############################################################################## | |
103 | ||
104 | sub opt_full_paths { | |
105 | return $$Full_paths if ref $Full_paths; | |
106 | return $Full_paths; | |
107 | } | |
108 | ||
109 | ############################################################################## | |
110 | ||
111 | sub configure { | |
112 | my %args = @_; | |
113 | ||
114 | foreach my $key (keys %args) { | |
115 | if($key eq 'full_paths') { | |
116 | $Full_paths = $args{$key}; | |
117 | } else { | |
118 | fatal "Midas::Paths does not recongnize configuration option ". | |
119 | "$key.\n", M_BADCONFIG; | |
120 | } | |
121 | } | |
122 | ||
123 | return ( full_paths => opt_full_paths ); | |
124 | ||
125 | } | |
126 | ||
127 | ############################################################################## | |
128 | ||
129 | # compact_path | |
130 | # Converts to full or relative (to $relto or cwd) path, whichever is shorter. | |
131 | # If Full_Paths is enabled, then always return full path. | |
132 | ||
133 | ############################################################################## | |
134 | ||
135 | sub compact_path { | |
136 | my $path = shift; | |
137 | my $relto = shift; | |
138 | ||
139 | $relto = getcwd unless defined $relto; | |
140 | my $abs = File::Spec->rel2abs($path, $relto); | |
141 | my $rel = File::Spec->abs2rel($abs, $relto); | |
142 | ||
143 | my $compact = ((length $rel) < (length $abs)) ? $rel : $abs; | |
144 | $compact = '.' if length($compact) == 0; | |
145 | ||
146 | return opt_full_paths() ? $abs : $compact; | |
147 | } | |
148 | ||
149 | ############################################################################## | |
150 | ||
151 | sub full_path { | |
152 | my $path = shift; | |
153 | my $relto = shift; | |
154 | ||
155 | $relto = getcwd unless defined $relto; | |
156 | my $abs = File::Spec->rel2abs($path, $relto); | |
157 | return $abs; | |
158 | } | |
159 | ||
160 | ############################################################################## | |
161 | ||
162 | sub cd { | |
163 | my $dir = shift; | |
164 | if(opt_full_paths()) { | |
165 | $dir = File::Spec->rel2abs($dir); | |
166 | } | |
167 | chat "cd $dir\n"; | |
168 | chdir $dir or fatal "Can't cd to $dir: $!\n", M_DIR; | |
169 | } | |
170 | ||
171 | ############################################################################## | |
172 | ||
173 | # Get filename. $file argument is a full path or a path relative to | |
174 | # build_dir. Second argument defines build_dir. If no second | |
175 | # argument, assume build_dir is cwd. If it's a string, assume the | |
176 | # string is build_dir. If it's a reference, assume it's a | |
177 | # Midas::State object. Return value is the compact path to the file. | |
178 | ||
179 | ############################################################################## | |
180 | ||
181 | sub path_to_build_file { | |
182 | my $file = shift; | |
183 | my $arg = shift; # either build_dir or state object or undef for build=cwd | |
184 | ||
185 | my $build_dir; | |
186 | if(not defined $arg) { | |
187 | $build_dir = getcwd; | |
188 | } elsif (ref $arg) { | |
189 | my $state = $arg; | |
190 | ||
191 | # Do the require at this late date so as to not mess up exports | |
192 | # (this is a circular include). | |
193 | ||
194 | require Midas::State; | |
195 | ||
196 | $build_dir = $state->get_build_dir('-abs'); | |
197 | } else { | |
198 | $build_dir = $arg; | |
199 | } | |
200 | ||
201 | my $expanded_file; | |
202 | if($file =~ m|^/|) { | |
203 | $expanded_file = $file; | |
204 | } else { | |
205 | $expanded_file = File::Spec->rel2abs($file, $build_dir); | |
206 | } | |
207 | ||
208 | return compact_path $expanded_file; | |
209 | } | |
210 | ||
211 | ############################################################################## | |
212 | ############################################################################## | |
213 | ||
214 | 1; |