| 1 | # -*- perl -*- |
| 2 | |
| 3 | package Midas::Paths; |
| 4 | use strict; |
| 5 | |
| 6 | require Exporter; |
| 7 | use Cwd; |
| 8 | use File::Spec; |
| 9 | |
| 10 | |
| 11 | use Midas::Command; |
| 12 | use Midas::Error; |
| 13 | |
| 14 | our @ISA = qw(Exporter); |
| 15 | our @EXPORT = qw(cd compact_path full_path |
| 16 | path_to_build_file); |
| 17 | |
| 18 | our $Full_paths = 0; |
| 19 | |
| 20 | ############################################################################## |
| 21 | |
| 22 | # Note this function is not at all robust. Should work on that |
| 23 | sub are_dirs_same { |
| 24 | my $dir1 = shift; |
| 25 | my $dir2 = shift; |
| 26 | |
| 27 | my $canon_dir1 = File::Spec->canonpath(File::Spec->rel2abs($dir1)); |
| 28 | my $canon_dir2 = File::Spec->canonpath(File::Spec->rel2abs($dir2)); |
| 29 | |
| 30 | return ($canon_dir1 eq $canon_dir2); |
| 31 | } |
| 32 | |
| 33 | ############################################################################## |
| 34 | |
| 35 | # ACTUALLY A CLASS METHOD |
| 36 | sub pushd { |
| 37 | my $class = shift; |
| 38 | my $dir = shift; |
| 39 | |
| 40 | my $this = {}; |
| 41 | bless $this, $class; |
| 42 | |
| 43 | if(not are_dirs_same($dir, getcwd)) { |
| 44 | $this->{old} = getcwd; |
| 45 | cd($dir); |
| 46 | } |
| 47 | |
| 48 | return $this; |
| 49 | } |
| 50 | |
| 51 | ############################################################################## |
| 52 | |
| 53 | # Not for public consumption |
| 54 | sub popd { |
| 55 | my $this = shift; |
| 56 | return unless defined $this->{old}; |
| 57 | cd(compact_path($this->{old})); |
| 58 | } |
| 59 | |
| 60 | ############################################################################## |
| 61 | |
| 62 | # implicit call to popd |
| 63 | sub DESTROY { |
| 64 | my $this = shift; |
| 65 | $this->popd(); |
| 66 | } |
| 67 | |
| 68 | ############################################################################## |
| 69 | |
| 70 | sub opt_full_paths { |
| 71 | return $$Full_paths if ref $Full_paths; |
| 72 | return $Full_paths; |
| 73 | } |
| 74 | |
| 75 | ############################################################################## |
| 76 | |
| 77 | sub configure { |
| 78 | my %args = @_; |
| 79 | |
| 80 | foreach my $key (keys %args) { |
| 81 | if($key eq 'full_paths') { |
| 82 | $Full_paths = $args{$key}; |
| 83 | } else { |
| 84 | fatal "Midas::Paths does not recongnize configuration option ". |
| 85 | "$key.\n", M_BADCONFIG; |
| 86 | } |
| 87 | } |
| 88 | |
| 89 | return ( full_paths => opt_full_paths ); |
| 90 | |
| 91 | } |
| 92 | |
| 93 | ############################################################################## |
| 94 | |
| 95 | # compact_path |
| 96 | # Converts to full or relative (to $relto or cwd) path, whichever is shorter. |
| 97 | # If Full_Paths is enabled, then always return full path. |
| 98 | |
| 99 | ############################################################################## |
| 100 | |
| 101 | sub compact_path { |
| 102 | my $path = shift; |
| 103 | my $relto = shift; |
| 104 | |
| 105 | $relto = getcwd unless defined $relto; |
| 106 | my $abs = File::Spec->rel2abs($path, $relto); |
| 107 | my $rel = File::Spec->abs2rel($abs, $relto); |
| 108 | |
| 109 | my $compact = ((length $rel) < (length $abs)) ? $rel : $abs; |
| 110 | $compact = '.' if length($compact) == 0; |
| 111 | |
| 112 | return opt_full_paths() ? $abs : $compact; |
| 113 | } |
| 114 | |
| 115 | ############################################################################## |
| 116 | |
| 117 | sub full_path { |
| 118 | my $path = shift; |
| 119 | my $relto = shift; |
| 120 | |
| 121 | $relto = getcwd unless defined $relto; |
| 122 | my $abs = File::Spec->rel2abs($path, $relto); |
| 123 | return $abs; |
| 124 | } |
| 125 | |
| 126 | ############################################################################## |
| 127 | |
| 128 | sub cd { |
| 129 | my $dir = shift; |
| 130 | if(opt_full_paths()) { |
| 131 | $dir = File::Spec->rel2abs($dir); |
| 132 | } |
| 133 | chat "cd $dir\n"; |
| 134 | chdir $dir or fatal "Can't cd to $dir: $!\n", M_DIR; |
| 135 | } |
| 136 | |
| 137 | ############################################################################## |
| 138 | |
| 139 | # Get filename. $file argument is a full path or a path relative to |
| 140 | # build_dir. Second argument defines build_dir. If no second |
| 141 | # argument, assume build_dir is cwd. If it's a string, assume the |
| 142 | # string is build_dir. If it's a reference, assume it's a |
| 143 | # Midas::State object. Return value is the compact path to the file. |
| 144 | |
| 145 | ############################################################################## |
| 146 | |
| 147 | sub path_to_build_file { |
| 148 | my $file = shift; |
| 149 | my $arg = shift; # either build_dir or state object or undef for build=cwd |
| 150 | |
| 151 | my $build_dir; |
| 152 | if(not defined $arg) { |
| 153 | $build_dir = getcwd; |
| 154 | } elsif (ref $arg) { |
| 155 | my $state = $arg; |
| 156 | |
| 157 | # Do the require at this late date so as to not mess up exports |
| 158 | # (this is a circular include). |
| 159 | |
| 160 | require Midas::State; |
| 161 | |
| 162 | $build_dir = $state->get_build_dir('-abs'); |
| 163 | } else { |
| 164 | $build_dir = $arg; |
| 165 | } |
| 166 | |
| 167 | my $expanded_file; |
| 168 | if($file =~ m|^/|) { |
| 169 | $expanded_file = $file; |
| 170 | } else { |
| 171 | $expanded_file = File::Spec->rel2abs($file, $build_dir); |
| 172 | } |
| 173 | |
| 174 | return compact_path $expanded_file; |
| 175 | } |
| 176 | |
| 177 | ############################################################################## |
| 178 | ############################################################################## |
| 179 | |
| 180 | 1; |