Commit | Line | Data |
3fea05b9 |
1 | package Probe::Perl; |
2 | |
3 | use vars qw( $VERSION ); |
4 | $VERSION = '0.01'; |
5 | |
6 | use strict; |
7 | |
8 | # TODO: cache values derived from launching an external perl process |
9 | # TODO: docs refer to Config.pm and $self->{config} |
10 | |
11 | |
12 | use Config; |
13 | use File::Spec; |
14 | |
15 | sub new { |
16 | my $class = shift; |
17 | my $data = shift || {}; |
18 | return bless( $data, $class ); |
19 | } |
20 | |
21 | sub config { |
22 | my ($self, $key) = (shift, shift); |
23 | if (@_) { |
24 | unless (ref $self) { |
25 | die "Can't set config values via $self->config(). Use $self->new() to create a local view"; |
26 | } |
27 | $self->{$key} = shift; |
28 | } |
29 | return ref($self) && exists $self->{$key} ? $self->{$key} : $Config{$key}; |
30 | } |
31 | |
32 | sub config_revert { |
33 | my $self = shift; |
34 | die "Can't use config_revert() as a class method" unless ref($self); |
35 | |
36 | delete $self->{$_} foreach @_; |
37 | } |
38 | |
39 | sub perl_version { |
40 | my $self = shift; |
41 | # Check the current perl interpreter |
42 | # It's much more convenient to use $] here than $^V, but 'man |
43 | # perlvar' says I'm not supposed to. Bloody tyrant. |
44 | return $^V ? $self->perl_version_to_float(sprintf( "%vd", $^V )) : $]; |
45 | } |
46 | |
47 | sub perl_version_to_float { |
48 | my ($self, $version) = @_; |
49 | $version =~ s/\./../; # Double up the first dot so the output has one dot remaining |
50 | $version =~ s/\.(\d+)/sprintf( '%03d', $1 )/eg; |
51 | return $version; |
52 | } |
53 | |
54 | sub perl_is_same { |
55 | my ($self, $perl) = @_; |
56 | return `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig; |
57 | } |
58 | |
59 | sub find_perl_interpreter { |
60 | my $self = shift; |
61 | |
62 | return $^X if File::Spec->file_name_is_absolute($^X); |
63 | |
64 | my $exe = $self->config('exe_ext'); |
65 | |
66 | my $thisperl = $^X; |
67 | if ($self->os_type eq 'VMS') { |
68 | # VMS might have a file version at the end |
69 | $thisperl .= $exe unless $thisperl =~ m/$exe(;\d+)?$/i; |
70 | } elsif (defined $exe) { |
71 | $thisperl .= $exe unless $thisperl =~ m/$exe$/i; |
72 | } |
73 | |
74 | foreach my $perl ( $self->config('perlpath'), |
75 | map( File::Spec->catfile($_, $thisperl), |
76 | File::Spec->path() ) |
77 | ) { |
78 | return $perl if -f $perl and $self->perl_is_same($perl); |
79 | } |
80 | return; |
81 | } |
82 | |
83 | # Determine the default @INC for this Perl |
84 | sub perl_inc { |
85 | my $self = shift; |
86 | |
87 | local $ENV{PERL5LIB}; # this is not considered part of the default. |
88 | |
89 | my $perl = $self->find_perl_interpreter(); |
90 | |
91 | my @inc = `$perl -l -e print -e for -e \@INC`; |
92 | chomp @inc; |
93 | |
94 | return @inc; |
95 | } |
96 | |
97 | |
98 | { |
99 | my %OSTYPES = qw( |
100 | aix Unix |
101 | bsdos Unix |
102 | dgux Unix |
103 | dynixptx Unix |
104 | freebsd Unix |
105 | linux Unix |
106 | hpux Unix |
107 | irix Unix |
108 | darwin Unix |
109 | machten Unix |
110 | next Unix |
111 | openbsd Unix |
112 | netbsd Unix |
113 | dec_osf Unix |
114 | svr4 Unix |
115 | svr5 Unix |
116 | sco_sv Unix |
117 | unicos Unix |
118 | unicosmk Unix |
119 | solaris Unix |
120 | sunos Unix |
121 | cygwin Unix |
122 | os2 Unix |
123 | |
124 | dos Windows |
125 | MSWin32 Windows |
126 | |
127 | os390 EBCDIC |
128 | os400 EBCDIC |
129 | posix-bc EBCDIC |
130 | vmesa EBCDIC |
131 | |
132 | MacOS MacOS |
133 | VMS VMS |
134 | VOS VOS |
135 | riscos RiscOS |
136 | amigaos Amiga |
137 | mpeix MPEiX |
138 | ); |
139 | |
140 | |
141 | sub os_type { |
142 | my $class = shift; |
143 | return $OSTYPES{shift || $^O}; |
144 | } |
145 | } |
146 | |
147 | |
148 | 1; |
149 | |
150 | __END__ |
151 | |
152 | |
153 | =head1 NAME |
154 | |
155 | Probe::Perl - Information about the currently running perl |
156 | |
157 | =head1 SYNOPSIS |
158 | |
159 | use Probe::Perl; |
160 | $p = Probe::Perl->new(); |
161 | |
162 | # Version of this perl as a floating point number |
163 | $ver = $p->perl_version(); |
164 | $ver = Probe::Perl->perl_version(); |
165 | |
166 | # Convert a multi-dotted string to a floating point number |
167 | $ver = $p->perl_version_to_float($ver); |
168 | $ver = Probe::Perl->perl_version_to_float($ver); |
169 | |
170 | # Check if the given perl is the same as the one currently running |
171 | $bool = $p->perl_is_same($perl_path); |
172 | $bool = Probe::Perl->perl_is_same($perl_path); |
173 | |
174 | # Find a path to the currently-running perl |
175 | $path = $p->find_perl_interpreter(); |
176 | $path = Probe::Perl->find_perl_interpreter(); |
177 | |
178 | # Get @INC before run-time additions |
179 | @paths = $p->perl_inc(); |
180 | @paths = Probe::Perl->perl_inc(); |
181 | |
182 | # Get the general type of operating system |
183 | $type = $p->os_type(); |
184 | $type = Probe::Perl->os_type(); |
185 | |
186 | # Access Config.pm values |
187 | $val = $p->config('foo'); |
188 | $val = Probe::Perl->config('foo'); |
189 | $p->config('foo' => 'bar'); # Set locally |
190 | $p->config_revert('foo'); # Revert |
191 | |
192 | =head1 DESCRIPTION |
193 | |
194 | This module provides methods for obtaining information about the |
195 | currently running perl interpreter. It originally began life as code |
196 | in the C<Module::Build> project, but has been externalized here for |
197 | general use. |
198 | |
199 | =head1 METHODS |
200 | |
201 | =over 4 |
202 | |
203 | =item new() |
204 | |
205 | Creates a new Probe::Perl object and returns it. Most methods in |
206 | the Probe::Perl packages are available as class methods, so you |
207 | don't always need to create a new object. But if you want to create a |
208 | mutable view of the C<Config.pm> data, it's necessary to create an |
209 | object to store the values in. |
210 | |
211 | =item config( $key [, $value] ) |
212 | |
213 | Returns the C<Config.pm> value associated with C<$key>. If C<$value> |
214 | is also specified, then the value is set to C<$value> for this view of |
215 | the data. In this case, C<config()> must be called as an object |
216 | method, not a class method. |
217 | |
218 | =item config_revert( $key ) |
219 | |
220 | Removes any user-assigned value in this view of the C<Config.pm> data. |
221 | |
222 | =item find_perl_interpreter( ) |
223 | |
224 | Returns the absolute path of this perl interpreter. This is actually |
225 | sort of a tricky thing to discover sometimes - in these cases we use |
226 | C<perl_is_same()> to verify. |
227 | |
228 | =item perl_version( ) |
229 | |
230 | Returns the version of this perl interpreter as a perl-styled version |
231 | number using C<perl_version_to_float()>. Uses C<$^V> if your perl is |
232 | recent enough, otherwise uses C<$]>. |
233 | |
234 | =item perl_version_to_float( $version ) |
235 | |
236 | Formats C<$version> as a perl-styled version number like C<5.008001>. |
237 | |
238 | =item perl_is_same( $perl ) |
239 | |
240 | Given the name of a perl interpreter, this method determines if it has |
241 | the same configuration as the one represented by the current perl |
242 | instance. Usually this means it's exactly the same |
243 | |
244 | =item perl_inc( ) |
245 | |
246 | Returns a list of directories in this perl's C<@INC> path, I<before> |
247 | any entries from C<use lib>, C<$ENV{PERL5LIB}>, or C<-I> switches are |
248 | added. |
249 | |
250 | =item os_type( [$osname] ) |
251 | |
252 | Returns a generic OS type (e.g. "Unix", "Windows", "MacOS") for the |
253 | given OS name. If no OS name is given it uses the value in $^O, which |
254 | is the same as $Config{osname}. |
255 | |
256 | =back |
257 | |
258 | =head1 AUTHOR |
259 | |
260 | Randy W. Sims <randys@thepierianspring.org> |
261 | |
262 | Based partly on code from the Module::Build project, by Ken Williams |
263 | <kwilliams@cpan.org> and others. |
264 | |
265 | =head1 COPYRIGHT |
266 | |
267 | Copyright 2005 Ken Williams and Randy Sims. All rights reserved. |
268 | |
269 | This library is free software; you can redistribute it and/or |
270 | modify it under the same terms as Perl itself. |
271 | |
272 | =cut |