Filename | /var/www/foswikidev/core/lib/Foswiki/Configure/Dependency.pm |
Statements | Executed 36 statements in 3.22ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 17µs | 63µs | BEGIN@20 | Foswiki::Configure::Dependency::
1 | 1 | 1 | 14µs | 26µs | BEGIN@17 | Foswiki::Configure::Dependency::
1 | 1 | 1 | 10µs | 34µs | BEGIN@22 | Foswiki::Configure::Dependency::
1 | 1 | 1 | 9µs | 13µs | BEGIN@18 | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | _compare_cpan_versions | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | _compare_extension_versions | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | _decodeReleaseString | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | _digitise_tuples | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | checkDependency | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | checkPerlModules | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | compare_using_cpan_version | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | compare_versions | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | extractModuleVersion | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | new | Foswiki::Configure::Dependency::
0 | 0 | 0 | 0s | 0s | studyInstallation | Foswiki::Configure::Dependency::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # See bottom of file for license and copyright information | ||||
2 | |||||
3 | =begin TML | ||||
4 | |||||
5 | ---+ package Foswiki::Configure::Dependency | ||||
6 | |||||
7 | This module defines a dependency required by a Foswiki module and provides | ||||
8 | functions to test if the dependency is installed, and compare versions with | ||||
9 | the required version. | ||||
10 | |||||
11 | It is also used to examine the installed version of a Foswiki module. | ||||
12 | |||||
13 | =cut | ||||
14 | |||||
15 | package Foswiki::Configure::Dependency; | ||||
16 | |||||
17 | 2 | 26µs | 2 | 38µs | # spent 26µs (14+12) within Foswiki::Configure::Dependency::BEGIN@17 which was called:
# once (14µs+12µs) by Foswiki::Configure::Checker::BEGIN@36 at line 17 # spent 26µs making 1 call to Foswiki::Configure::Dependency::BEGIN@17
# spent 12µs making 1 call to strict::import |
18 | 2 | 35µs | 2 | 17µs | # spent 13µs (9+4) within Foswiki::Configure::Dependency::BEGIN@18 which was called:
# once (9µs+4µs) by Foswiki::Configure::Checker::BEGIN@36 at line 18 # spent 13µs making 1 call to Foswiki::Configure::Dependency::BEGIN@18
# spent 4µs making 1 call to warnings::import |
19 | |||||
20 | 3 | 55µs | 3 | 109µs | # spent 63µs (17+46) within Foswiki::Configure::Dependency::BEGIN@20 which was called:
# once (17µs+46µs) by Foswiki::Configure::Checker::BEGIN@36 at line 20 # spent 63µs making 1 call to Foswiki::Configure::Dependency::BEGIN@20
# spent 28µs making 1 call to version::import
# spent 18µs making 1 call to version::vxs::_VERSION |
21 | |||||
22 | 2 | 2.99ms | 2 | 58µs | # spent 34µs (10+24) within Foswiki::Configure::Dependency::BEGIN@22 which was called:
# once (10µs+24µs) by Foswiki::Configure::Checker::BEGIN@36 at line 22 # spent 34µs making 1 call to Foswiki::Configure::Dependency::BEGIN@22
# spent 24µs making 1 call to Exporter::import |
23 | |||||
24 | 1 | 3µs | my @MNAMES = qw(jan feb mar apr may jun jul aug sep oct nov dec); | ||
25 | 1 | 2µs | my $mnamess = join( '|', @MNAMES ); | ||
26 | 1 | 15µs | my $MNAME = qr/$mnamess/i; | ||
27 | 1 | 200ns | my %M2N; | ||
28 | 13 | 12µs | foreach ( 0 .. $#MNAMES ) { $M2N{ $MNAMES[$_] } = $_ + 1; } | ||
29 | |||||
30 | 1 | 5µs | my %STRINGOPMAP = ( | ||
31 | 'eq' => 'eq', | ||||
32 | 'ne' => 'ne', | ||||
33 | 'lt' => 'lt', | ||||
34 | 'gt' => 'gt', | ||||
35 | 'le' => 'le', | ||||
36 | 'ge' => 'ge', | ||||
37 | '=' => 'eq', | ||||
38 | '==' => 'eq', | ||||
39 | '!=' => 'ne', | ||||
40 | '<' => 'lt', | ||||
41 | '>' => 'gt', | ||||
42 | '<=' => 'le', | ||||
43 | '>=' => 'ge' | ||||
44 | ); | ||||
45 | |||||
46 | 1 | 200ns | my $MAXINT = 0x7FFFFFFF; | ||
47 | |||||
48 | #--------------------------------------------------------------------------# | ||||
49 | # LAX Version regexp components TAKEN FROM VERSION 0.96 | ||||
50 | # - version 0.77 requried for core doesn't have the regex | ||||
51 | # SMELL: Replace this with $version::LAX once version 0.78 or > is required | ||||
52 | #--------------------------------------------------------------------------# | ||||
53 | |||||
54 | # Fraction part of a decimal version number. This is a common part of | ||||
55 | # both strict and lax decimal versions | ||||
56 | |||||
57 | 1 | 1µs | my $FRACTION_PART = qr/\.[0-9]+/; | ||
58 | |||||
59 | # First part of either decimal or dotted-decimal lax version number. | ||||
60 | # Unsigned integer, but allowing leading zeros. Always interpreted | ||||
61 | # as decimal. However, some forms of the resulting syntax give odd | ||||
62 | # results if used as ordinary Perl expressions, due to how perl treats | ||||
63 | # octals. E.g. | ||||
64 | # version->new("010" ) == 10 | ||||
65 | # version->new( 010 ) == 8 | ||||
66 | # version->new( 010.2) == 82 # "8" . "2" | ||||
67 | |||||
68 | 1 | 900ns | my $LAX_INTEGER_PART = qr/[0-9]+/; | ||
69 | |||||
70 | # Second and subsequent part of a lax dotted-decimal version number. | ||||
71 | # Leading zeroes are permitted, and the number is always decimal. No | ||||
72 | # limit on the numerical value or number of digits, so there is the | ||||
73 | # possibility of overflow when converting to decimal form. | ||||
74 | |||||
75 | 1 | 700ns | my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; | ||
76 | |||||
77 | # Alpha suffix part of lax version number syntax. Acts like a | ||||
78 | # dotted-decimal part. | ||||
79 | |||||
80 | 1 | 700ns | my $LAX_ALPHA_PART = qr/_[0-9]+/; | ||
81 | |||||
82 | #--------------------------------------------------------------------------# | ||||
83 | # Lax version regexp definitions | ||||
84 | #--------------------------------------------------------------------------# | ||||
85 | |||||
86 | # Lax decimal version number. Just like the strict one except for | ||||
87 | # allowing an alpha suffix or allowing a leading or trailing | ||||
88 | # decimal-point | ||||
89 | |||||
90 | 1 | 18µs | my $LAX_DECIMAL_VERSION = | ||
91 | qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? | ||||
92 | | | ||||
93 | $FRACTION_PART $LAX_ALPHA_PART? | ||||
94 | /x; | ||||
95 | |||||
96 | # Lax dotted-decimal version number. Distinguished by having either | ||||
97 | # leading "v" or at least three non-alpha parts. Alpha part is only | ||||
98 | # permitted if there are at least two non-alpha parts. Strangely | ||||
99 | # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, | ||||
100 | # so when there is no "v", the leading part is optional | ||||
101 | |||||
102 | 1 | 14µs | my $LAX_DOTTED_DECIMAL_VERSION = qr/ | ||
103 | v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? | ||||
104 | | | ||||
105 | $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? | ||||
106 | /x; | ||||
107 | |||||
108 | # Complete lax version number syntax -- should generally be used | ||||
109 | # anchored: qr/ \A $LAX \z /x | ||||
110 | # | ||||
111 | # REMOVED: | ||||
112 | # The string 'undef' is a special case to make for easier handling | ||||
113 | # of return values from ExtUtils::MM->parse_version | ||||
114 | |||||
115 | 1 | 22µs | my $LAX = qr/ $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; | ||
116 | |||||
117 | #--------------------------------------------------------------------------# | ||||
118 | |||||
119 | =begin TML | ||||
120 | |||||
121 | ---++ ClassMethod new( %opts ) | ||||
122 | |||||
123 | Create an object instance representing a single dependency, as read from DEPENDENCIES | ||||
124 | * %opts | ||||
125 | * =name => unqualified name e.g. SafeWikiPlugin= | ||||
126 | * =module => qualified module e.g Foswiki::Plugins::SafeWikiPlugin= | ||||
127 | * If a qualified =module= is not provided, all possible Foswiki/TWiki module types are searched for =type=perl= | ||||
128 | * =type => perl|cpan|external= | ||||
129 | * =perl= is a Foswiki or TWiki module. =external= is used for any program other than a perl module. External dependencies are __not__ checked. | ||||
130 | * =version => version condition e.g. ">1.2.3"= | ||||
131 | * =trigger => ONLYIF condition= (Specifies a version of another module, such as the Foswiki Func API) | ||||
132 | * =description => text= | ||||
133 | |||||
134 | * Instance variables set by calling studyInstallation() or indirectly by calling check() | ||||
135 | * =installed => True if module is installed= | ||||
136 | * =installedVersion => $VERSION string from module= | ||||
137 | * =installedRelease => $RELEASE string from module (or $VERSION)= | ||||
138 | * =notes => text Notes on condition of module= (ex. fails due to missing dependency) | ||||
139 | |||||
140 | =cut | ||||
141 | |||||
142 | sub new { | ||||
143 | my ( $class, %opts ) = @_; | ||||
144 | my $this = bless( \%opts, $class ); | ||||
145 | |||||
146 | # If {module} is defined but not {name}, we can usually work it out | ||||
147 | if ( $this->{module} && !$this->{name} ) { | ||||
148 | $this->{name} = $this->{module}; | ||||
149 | $this->{name} =~ s/^.*:://; | ||||
150 | } | ||||
151 | |||||
152 | # If {name} is defined but {module} is not, we'll have to work that | ||||
153 | # out when we try to load the module in studyInstallation. | ||||
154 | die "No name or module in dependency" unless $this->{name}; | ||||
155 | |||||
156 | # If no version condition is given, assume we will just test that the | ||||
157 | # module is installed (any version) | ||||
158 | $this->{version} ||= '>=0'; | ||||
159 | |||||
160 | # Other defaults | ||||
161 | $this->{trigger} ||= 1; | ||||
162 | $this->{type} ||= 'external'; # assume external module | ||||
163 | $this->{description} ||= 'This module has no description.'; | ||||
164 | $this->{notes} = ''; | ||||
165 | |||||
166 | return $this; | ||||
167 | } | ||||
168 | |||||
169 | =begin TML | ||||
170 | |||||
171 | ---++ ObjectMethod check() -> ($ok, $msg) | ||||
172 | |||||
173 | Check whether the dependency is satisfied by a currently-installed module. | ||||
174 | * Return: ($ok, $msg) | ||||
175 | * $ok is a boolean indicating success/failure | ||||
176 | * $msg is a helpful message describing the failure | ||||
177 | |||||
178 | =cut | ||||
179 | |||||
180 | sub checkDependency { | ||||
181 | my $this = shift; | ||||
182 | |||||
183 | # reject non-Perl dependencies | ||||
184 | if ( $this->{type} !~ /^(?:perl|cpan)$/i ) { | ||||
185 | return ( 0, <<LALA ); | ||||
186 | $this->{module} is type '$this->{type}', and cannot be automatically checked. | ||||
187 | Please check it manually and install if necessary. | ||||
188 | LALA | ||||
189 | } | ||||
190 | |||||
191 | # Examine the current install of the module | ||||
192 | if ( !$this->studyInstallation() ) { | ||||
193 | return ( 0, <<TINKYWINKY ); | ||||
194 | $this->{module} version $this->{version} required | ||||
195 | -- $this->{type} $this->{notes} | ||||
196 | TINKYWINKY | ||||
197 | } | ||||
198 | elsif ( $this->{version} =~ m/^\s*([<>=]+)?\s*(.+)/ ) { | ||||
199 | |||||
200 | # the version field is a condition | ||||
201 | my $op = $1 || '>='; | ||||
202 | my $requiredVersion = $2; | ||||
203 | unless ( $this->compare_versions( $op, $requiredVersion ) ) { | ||||
204 | |||||
205 | # module doesn't meet this condition | ||||
206 | return ( 0, <<PO ); | ||||
207 | $this->{module} version $op $requiredVersion required | ||||
208 | -- installed version is $this->{installedRelease} | ||||
209 | PO | ||||
210 | } | ||||
211 | } | ||||
212 | return ( 1, <<DIPSY ); | ||||
213 | $this->{module} version $this->{installedRelease} installed | ||||
214 | DIPSY | ||||
215 | } | ||||
216 | |||||
217 | =begin TML | ||||
218 | |||||
219 | ---++ ObjectMethod studyInstallation() | ||||
220 | |||||
221 | Check the current installation, populating the ={installedRelease}= and ={installedVersion}= fields, and returning true if the extension is installed. | ||||
222 | ={notes}= will also be set when certain conditions are discovered (example: missing dependencies or other compile failures). | ||||
223 | |||||
224 | * Return: $ok | ||||
225 | * $ok is a boolean indicating success/failure. If the module is found and a VERSION and RELEASE are discovered, the method returns true. | ||||
226 | |||||
227 | =cut | ||||
228 | |||||
229 | sub studyInstallation { | ||||
230 | my $this = shift; | ||||
231 | my $load_errors = ''; | ||||
232 | |||||
233 | my ( $inst, $ver, $loc, $rel ); | ||||
234 | |||||
235 | if ( !$this->{module} ) { | ||||
236 | my $lib = ( $this->{name} =~ m/Plugin$/ ) ? 'Plugins' : 'Contrib'; | ||||
237 | foreach my $namespace (qw(Foswiki TWiki)) { | ||||
238 | my $path = $namespace . '::' . $lib . '::' . $this->{name}; | ||||
239 | ( $inst, $ver, $loc, $rel ) = | ||||
240 | extractModuleVersion( $path, 'magic' ); | ||||
241 | if ($inst) { | ||||
242 | $this->{module} = $path; | ||||
243 | last; | ||||
244 | } | ||||
245 | } | ||||
246 | } | ||||
247 | else { | ||||
248 | ( $inst, $ver, $loc, $rel ) = | ||||
249 | extractModuleVersion( $this->{module}, | ||||
250 | $this->{module} =~ m/(?:Foswiki|TWiki)/ ); | ||||
251 | } | ||||
252 | |||||
253 | if ($inst) { | ||||
254 | $this->{installedVersion} = $ver; | ||||
255 | $this->{installedRelease} = $rel || $ver; | ||||
256 | $this->{installed} = 1; | ||||
257 | $this->{location} = $loc; | ||||
258 | if ( -l $loc ) { | ||||
259 | |||||
260 | # Assume pseudo-installed | ||||
261 | $this->{installedVersion} = '9999.99_999'; | ||||
262 | } | ||||
263 | } | ||||
264 | else { | ||||
265 | $this->{notes} = "module is not installed"; | ||||
266 | $this->{installedVersion} = ''; | ||||
267 | $this->{installedRelease} = ''; | ||||
268 | $this->{location} = ''; | ||||
269 | return 0; | ||||
270 | } | ||||
271 | |||||
272 | return 0 unless $this->{module}; | ||||
273 | return 1; | ||||
274 | } | ||||
275 | |||||
276 | sub compare_using_cpan_version { | ||||
277 | |||||
278 | my $va = shift; | ||||
279 | my $verA = ( $va =~ m/^v/ ) ? version->declare($va) : version->parse($va); | ||||
280 | my $op = shift; | ||||
281 | $op = '==' if $op eq '='; | ||||
282 | my $vb = shift; | ||||
283 | my $verB = ( $vb =~ m/^v/ ) ? version->declare($vb) : version->parse($vb); | ||||
284 | my $comparison = "\$verA $op \$verB"; | ||||
285 | return eval($comparison); | ||||
286 | } | ||||
287 | |||||
288 | =begin TML | ||||
289 | |||||
290 | ---++ ObjectMethod compare_versions ($condition, $release) | ||||
291 | |||||
292 | Compare versions (provided as $RELEASE, $VERSION) with a release specifier | ||||
293 | |||||
294 | Returns the boolean result of the comparison | ||||
295 | |||||
296 | =cut | ||||
297 | |||||
298 | sub compare_versions { | ||||
299 | my $this = shift; | ||||
300 | if ( $this->{type} eq 'perl' ) { | ||||
301 | |||||
302 | #print STDERR "Comparing TYPE PERL $this->{module}\n" if $this->{module}; | ||||
303 | return $this->_compare_extension_versions(@_); | ||||
304 | } | ||||
305 | else { | ||||
306 | |||||
307 | #print STDERR "Comparing TYPE cpan $this->{module}\n"; | ||||
308 | return $this->_compare_cpan_versions(@_); | ||||
309 | } | ||||
310 | } | ||||
311 | |||||
312 | # Heuristically compare version strings in cpan modules | ||||
313 | sub _compare_cpan_versions { | ||||
314 | my ( $this, $op, $b ) = @_; | ||||
315 | |||||
316 | my $a = $this->{installedVersion}; | ||||
317 | |||||
318 | return 0 if not defined $op or not exists $STRINGOPMAP{$op}; | ||||
319 | my $string_op = $STRINGOPMAP{$op}; | ||||
320 | |||||
321 | # CDot: changed largest char because collation order makes string | ||||
322 | # comparison weird in non-iso8859 locales | ||||
323 | my $largest_char = 'z'; | ||||
324 | |||||
325 | # remove leading and trailing whitespace | ||||
326 | # because ' X' should compare equal to 'X' | ||||
327 | $a =~ s/^\s+//; | ||||
328 | $a =~ s/\s+$//; | ||||
329 | $b =~ s/^\s+//; | ||||
330 | $b =~ s/\s+$//; | ||||
331 | |||||
332 | # $Rev$ without a number should compare higher than anything else | ||||
333 | $a =~ s/^\$Rev:?\s*\$$/$largest_char/; | ||||
334 | $b =~ s/^\$Rev:?\s*\$$/$largest_char/; | ||||
335 | |||||
336 | # remove the SVN marker text from the version number, if it is there | ||||
337 | $a =~ s/^\$Rev: (\d+) \$$/$1/; | ||||
338 | $b =~ s/^\$Rev: (\d+) \$$/$1/; | ||||
339 | |||||
340 | # swap the day-of-month and year around for ISO dates | ||||
341 | my $isoDatePattern = qr/^\d{1,2}-\d{1,2}-\d{4}$/; | ||||
342 | if ( $a =~ $isoDatePattern and $b =~ $isoDatePattern ) { | ||||
343 | $a =~ s/^(\d+)-(\d+)-(\d+)$/$3-$2-$1/; | ||||
344 | $b =~ s/^(\d+)-(\d+)-(\d+)$/$3-$2-$1/; | ||||
345 | } | ||||
346 | |||||
347 | # Change separator characters to be the same, | ||||
348 | # because X-Y-Z should compare equal to X.Y.Z | ||||
349 | # and combine adjacent separators, | ||||
350 | # because '6 jun 2009' should compare equal to '6 jun 2009' | ||||
351 | # Note: _ is not changed, it has special alpha significance for perl CPAN:version | ||||
352 | my $separator = '.'; | ||||
353 | $a =~ s([ ./-]+)($separator)g; | ||||
354 | $b =~ s([ ./-]+)($separator)g; | ||||
355 | |||||
356 | # Replace month-names with numbers and swap day-of-month and year | ||||
357 | # around to make them sortable as strings | ||||
358 | # but only do this if both versions look like a date | ||||
359 | my $datePattern = qr(\b\d{1,2}$separator$MNAME$separator\d{4}\b); | ||||
360 | if ( $a =~ $datePattern and $b =~ $datePattern ) { | ||||
361 | $a =~ | ||||
362 | s/(\d+)$separator($MNAME)$separator(\d+)/$3.$separator.$M2N{ lc($2) }.$separator.$1/ge; | ||||
363 | $b =~ | ||||
364 | s/(\d+)$separator($MNAME)$separator(\d+)/$3.$separator.$M2N{ lc($2) }.$separator.$1/ge; | ||||
365 | } | ||||
366 | |||||
367 | # convert to lowercase | ||||
368 | # because 'cairo' should compare less than 'Dakar' | ||||
369 | $a = lc($a); | ||||
370 | $b = lc($b); | ||||
371 | |||||
372 | # See if these are sane perl version strings, if so we can use CPAN version to compare | ||||
373 | if ( $a =~ m/^$LAX$/ && $b =~ m/^$LAX$/ ) { | ||||
374 | |||||
375 | #print STDERR "$a and $b match LAX version rules, TEST $op "; | ||||
376 | #print STDERR ( compare_using_cpan_version( $a, $op, $b )) ? " - TRUE\n" : " - FALSE \n"; | ||||
377 | return ( compare_using_cpan_version( $a, $op, $b ) ); | ||||
378 | } | ||||
379 | |||||
380 | # remove a leading 'v' if either are of the form X.Y | ||||
381 | # because vX.Y should compare equal to X.Y | ||||
382 | my $xDotYPattern = qr/^v?\s*\d+(?:$separator\d+)+/; | ||||
383 | if ( $a =~ $xDotYPattern or $b =~ $xDotYPattern ) { | ||||
384 | $a =~ s/^v\s*//; | ||||
385 | $b =~ s/^v\s*//; | ||||
386 | } | ||||
387 | |||||
388 | # work out how many characters there are in the longest sequence | ||||
389 | # of digits between the two versions | ||||
390 | my ($maxDigits) = | ||||
391 | reverse | ||||
392 | sort( map { length($_) } ( $a =~ m/(\d+)/g ), ( $b =~ m/(\d+)/g ), ); | ||||
393 | |||||
394 | # justify digit sequences so that they compare correctly. | ||||
395 | # E.g. '063' lt '103' | ||||
396 | $a =~ s/(\d+)/sprintf('%0'.$maxDigits.'u', $1)/ge; | ||||
397 | $b =~ s/(\d+)/sprintf('%0'.$maxDigits.'u', $1)/ge; | ||||
398 | |||||
399 | # there is no need to justify non-digit sequences | ||||
400 | # because 'alpha' compares less than 'beta' | ||||
401 | |||||
402 | # X should compare greater than X-beta1 | ||||
403 | # so append a high-value character to the | ||||
404 | # non-beta version if one version looks like | ||||
405 | # a beta and the other does not | ||||
406 | if ( $a =~ m/^$b$separator?beta/ ) { | ||||
407 | |||||
408 | # $a is beta of $b | ||||
409 | # $b should compare greater than $a | ||||
410 | $b .= $largest_char; | ||||
411 | } | ||||
412 | elsif ( $b =~ m/^$a$separator?beta/ ) { | ||||
413 | |||||
414 | # $b is beta of $a | ||||
415 | # $a should compare greater than $b | ||||
416 | $a .= $largest_char; | ||||
417 | } | ||||
418 | |||||
419 | my $comparison; | ||||
420 | if ( $a =~ m/^(\d+)(\.\d*)?$/ && $b =~ m/^(\d+)(\.\d*)?$/ ) { | ||||
421 | $op = '==' if $op eq '='; | ||||
422 | $a += 0; | ||||
423 | $b += 0; | ||||
424 | $comparison = "$a $op $b"; | ||||
425 | } | ||||
426 | else { | ||||
427 | $comparison = "'$a' $string_op '$b'"; | ||||
428 | } | ||||
429 | my $result = eval($comparison); | ||||
430 | |||||
431 | #print STDERR "[$comparison]->$result;\n"; | ||||
432 | return $result; | ||||
433 | } | ||||
434 | |||||
435 | # Compare foswiki extension versions using more rigorous rules | ||||
436 | # Returns true if the condition is true, false if not true, or invalid comparison | ||||
437 | sub _compare_extension_versions { | ||||
438 | |||||
439 | # $aRELEASE, $aVERSION - module release and svn version | ||||
440 | # $b - what we are comparing to (from DEPENDENCIES or configure FastReport) | ||||
441 | my ( $this, $op, $reqVer ) = @_; | ||||
442 | |||||
443 | my $aRELEASE = $this->{installedRelease}; | ||||
444 | my $aVERSION = $this->{installedVersion}; | ||||
445 | |||||
446 | # If the operator is not defined, or invalid, return false | ||||
447 | if ( not defined $op or not exists $STRINGOPMAP{$op} ) { | ||||
448 | $op = '"undefined"' unless defined $op; | ||||
449 | |||||
450 | #print STDERR "Unknown Operator $op \n"; | ||||
451 | return 0; | ||||
452 | } | ||||
453 | |||||
454 | my $string_op = $STRINGOPMAP{$op}; | ||||
455 | my $e = $b; | ||||
456 | |||||
457 | # First see what format the RELEASE string is in, and break it | ||||
458 | # down into a tuple (most significant first) | ||||
459 | my @atuple; | ||||
460 | my @btuple; | ||||
461 | my $baseType = ''; # Type of version/release string for this module | ||||
462 | my $reqType = ''; # Type of version/release string requested | ||||
463 | |||||
464 | unless ( defined $reqVer ) { | ||||
465 | |||||
466 | #print STDERR "Comparison not defined\n"; | ||||
467 | return 0; | ||||
468 | } | ||||
469 | |||||
470 | ( $reqType, @btuple ) = _decodeReleaseString($reqVer); | ||||
471 | |||||
472 | #print STDERR "WANT TO COMPARE TO $reqType\n"; | ||||
473 | |||||
474 | # Try version first. If it's a svn string, then need to try release | ||||
475 | if ( defined $aVERSION ) { | ||||
476 | |||||
477 | #print STDERR "Version $aVERSION defined\n"; | ||||
478 | ( $baseType, @atuple ) = | ||||
479 | _decodeReleaseString($aVERSION); # if defined $aVERSION; | ||||
480 | } | ||||
481 | |||||
482 | #print STDERR "VERSION decoded to $baseType\n" if ($baseType); | ||||
483 | unless ( defined $aVERSION ) { | ||||
484 | if ( defined $aRELEASE ) { | ||||
485 | |||||
486 | #print STDERR "Version undef, $aRELEASE defined\n"; | ||||
487 | ( $baseType, @atuple ) = _decodeReleaseString($aRELEASE); | ||||
488 | } | ||||
489 | } | ||||
490 | if ( $baseType eq 'svn' ) { | ||||
491 | unless ( $reqType eq 'svn' ) { | ||||
492 | |||||
493 | # Inconsistent VERSION, so try RELEASE | ||||
494 | if ( defined $aRELEASE ) { | ||||
495 | |||||
496 | #print STDERR "Release $aRELEASE defined\n"; | ||||
497 | ( $baseType, @atuple ) = _decodeReleaseString($aRELEASE); | ||||
498 | } | ||||
499 | } | ||||
500 | } | ||||
501 | |||||
502 | if ( $reqType eq 'date' ) { | ||||
503 | unless ( $baseType eq 'date' ) { | ||||
504 | |||||
505 | # Inconsistent VERSION, so try RELEASE | ||||
506 | if ( defined $aRELEASE ) { | ||||
507 | |||||
508 | #print STDERR "Release $aRELEASE defined\n"; | ||||
509 | ( $baseType, @atuple ) = _decodeReleaseString($aRELEASE); | ||||
510 | } | ||||
511 | } | ||||
512 | } | ||||
513 | unless ($baseType) { | ||||
514 | |||||
515 | #print STDERR "Unable to determine what to compare.\n"; | ||||
516 | return 0; | ||||
517 | } | ||||
518 | |||||
519 | #print STDERR "EXPECT $baseType $string_op BEXPECT $reqType \n"; | ||||
520 | |||||
521 | # Requested version is a svn release, Need to use VERSION instead of RELEASE stirng | ||||
522 | if ( $reqType eq 'svn' ) { | ||||
523 | |||||
524 | #print STDERR "Expecting SVN comparison, but RELEASE was $baseType \n"; | ||||
525 | ( $baseType, @atuple ) = _decodeReleaseString($aVERSION) | ||||
526 | if ( defined $aVERSION && $baseType ne 'svn' ); | ||||
527 | return 1 if ( $baseType eq 'tuple' ); | ||||
528 | return 0 unless ( $baseType eq 'svn' ); | ||||
529 | |||||
530 | } | ||||
531 | |||||
532 | # See if request is for anything > 0. If so, return true. | ||||
533 | if ( $reqType eq 'tuple' | ||||
534 | && scalar(@btuple) == 1 | ||||
535 | && $btuple[0] == 0 | ||||
536 | && $string_op eq 'gt' ) | ||||
537 | { | ||||
538 | |||||
539 | #print STDERR "'SPECIAL CASE - zero expected just means present\n"; | ||||
540 | return 1; | ||||
541 | } | ||||
542 | |||||
543 | # special handling for dates. | ||||
544 | if ( $reqType eq 'date' || $baseType eq 'date' ) { | ||||
545 | |||||
546 | # special case, if requested tuple, and installed date, this is probably | ||||
547 | # a migration to a version tuple, so return true to trigger an update | ||||
548 | return 1 | ||||
549 | if ( $reqType eq 'tuple' | ||||
550 | && $baseType eq 'date' ); | ||||
551 | |||||
552 | if ( $reqType ne $baseType ) { | ||||
553 | |||||
554 | return 0; | ||||
555 | } | ||||
556 | |||||
557 | if ( scalar(@btuple) != scalar(@atuple) || scalar(@btuple) != 3 ) { | ||||
558 | |||||
559 | #print STDERR "Incorrectly formatted date in $aRELEASE or $b\n"; | ||||
560 | } | ||||
561 | |||||
562 | # Simple validations - grossly invalid year, month or day. | ||||
563 | return 0 if ( $atuple[0] < 1970 || $btuple[0] < 1970 ); | ||||
564 | return 0 if ( $atuple[1] > 12 || $btuple[1] > 12 ); | ||||
565 | return 0 if ( $atuple[1] < 1 || $btuple[1] < 1 ); | ||||
566 | return 0 if ( $atuple[2] > 31 || $btuple[2] > 31 ); | ||||
567 | return 0 if ( $atuple[2] < 1 || $btuple[2] < 1 ); | ||||
568 | } | ||||
569 | |||||
570 | # We can't figure out the types, so just return false. | ||||
571 | return 0 if ( $baseType eq 'unknown' || $reqType eq 'unknown' ); | ||||
572 | |||||
573 | # Do the comparisons | ||||
574 | ( my $a, $b ) = _digitise_tuples( \@atuple, \@btuple ); | ||||
575 | my $comparison = "'$a' $string_op '$b'"; | ||||
576 | my $result = eval($comparison); | ||||
577 | |||||
578 | #print STDERR "[$comparison]->$result\n"; | ||||
579 | return $result; | ||||
580 | } | ||||
581 | |||||
582 | # Returns the type of the passed string | ||||
583 | # | ||||
584 | # What format is the release identifier? We support comparison | ||||
585 | # of five formats: | ||||
586 | # 1. A simple number (subversion revision). | ||||
587 | # 2 Encoded SVN $Rev$ formats | ||||
588 | # 3. A dd Mmm yyyy format date | ||||
589 | # 4. An ISO yyyy-mm-dd format date | ||||
590 | # 5. A tuple N(.M)+ | ||||
591 | |||||
592 | # SVN Versions should always be an SVN release number | ||||
593 | # coded in 3 formats | ||||
594 | # 1. $Rev: <some number> $ | ||||
595 | # 2. $Rev: <some number> (date)$ (Date is ignored) | ||||
596 | # 3. $Rev$ An unassigned Rev indicating a SVN checkout. | ||||
597 | |||||
598 | sub _decodeReleaseString { | ||||
599 | |||||
600 | my ($rel) = @_; | ||||
601 | my $form; | ||||
602 | my @tuple; | ||||
603 | |||||
604 | $rel =~ s/^\s+//; | ||||
605 | $rel =~ s/\s+$//; | ||||
606 | |||||
607 | if ( $rel =~ m/^(\d{4})-(\d{2})-(\d{2}).*$/ ) { | ||||
608 | |||||
609 | # ISO date | ||||
610 | @tuple = ( $1, $2, $3 ); | ||||
611 | $form = 'date'; | ||||
612 | } | ||||
613 | elsif ( $rel =~ m/^(\d+)\s+($MNAME)\s+(\d+).*$/i ) { | ||||
614 | |||||
615 | # dd Mmm YYY date | ||||
616 | @tuple = ( $3, $M2N{ lc $2 }, $1 ); | ||||
617 | $form = 'date'; | ||||
618 | } | ||||
619 | elsif ( $rel =~ m/^([0-9]{4,5})$/ ) { | ||||
620 | |||||
621 | #print STDERR "matching a svn VERSION\n"; | ||||
622 | # svn rev, 4-5 digit number | ||||
623 | @tuple = ($1); | ||||
624 | $form = 'svn'; | ||||
625 | } | ||||
626 | elsif ( $rel =~ m/^r([0-9]{1,6})$/ ) { | ||||
627 | |||||
628 | # svn rev, a 1-6 digit number prefixed by 'r' | ||||
629 | @tuple = ($1); | ||||
630 | $form = 'svn'; | ||||
631 | } | ||||
632 | elsif ( $rel =~ m/^V?(\d+([-_.]\d+)*).*?$/i ) { | ||||
633 | |||||
634 | # tuple e.g. 1.23.4 Note that a simple tuple could also be a low SVN rev. | ||||
635 | @tuple = split( /[-_.]/, $1 ); | ||||
636 | $form = 'tuple'; | ||||
637 | } | ||||
638 | elsif ( $rel =~ m/^\$Rev: (\d+)\s*\(.*\)$/ ) { | ||||
639 | |||||
640 | # 1234 (7 Aug 2009) | ||||
641 | # 1234 (2009-08-07) | ||||
642 | @tuple = ($1); | ||||
643 | $form = 'svn'; | ||||
644 | } | ||||
645 | elsif ( $rel =~ m/^\$Rev: (\d+).*\$$/ ) { | ||||
646 | |||||
647 | # $Rev: 1234$ | ||||
648 | @tuple = ($1); | ||||
649 | $form = 'svn'; | ||||
650 | } | ||||
651 | elsif ( $rel =~ m/^\$Rev:?\s*\$.*$/ ) { | ||||
652 | |||||
653 | # $Rev$ | ||||
654 | @tuple = ($MAXINT); | ||||
655 | $form = 'svn'; | ||||
656 | } | ||||
657 | elsif ( $rel =~ m/^\s?$/ ) { | ||||
658 | |||||
659 | # Blank or empty version | ||||
660 | @tuple = (0); | ||||
661 | $form = 'tuple'; | ||||
662 | } | ||||
663 | elsif ( $rel =~ m/^Foswiki-(\d+([-_.]\d+)*).*?$/i ) { | ||||
664 | @tuple = split( /[-_.]/, $1 ); | ||||
665 | $form = 'tuple'; | ||||
666 | } | ||||
667 | else { | ||||
668 | |||||
669 | # Some other format | ||||
670 | @tuple = (0); | ||||
671 | $form = 'unknown'; | ||||
672 | } | ||||
673 | |||||
674 | #print STDERR "RELEASE $rel decodes as $form, @tuple \n"; | ||||
675 | |||||
676 | return ( $form, @tuple ); | ||||
677 | } | ||||
678 | |||||
679 | # Given two tuples, convert them both into number strings, padding with | ||||
680 | # zeroes as necessary. | ||||
681 | sub _digitise_tuples { | ||||
682 | my ( $a, $b ) = @_; | ||||
683 | |||||
684 | my ($maxDigits) = reverse sort ( map { length($_) } ( @$a, @$b ) ); | ||||
685 | $a = join( | ||||
686 | '', | ||||
687 | map { | ||||
688 | if ( $_ eq 'HEAD' ) { $_ } | ||||
689 | else { sprintf( '%0' . $maxDigits . 'u', $_ ); } | ||||
690 | } @$a | ||||
691 | ); | ||||
692 | $b = join( | ||||
693 | '', | ||||
694 | map { | ||||
695 | if ( $_ eq 'HEAD' ) { $_ } | ||||
696 | else { sprintf( '%0' . $maxDigits . 'u', $_ ); } | ||||
697 | } @$b | ||||
698 | ); | ||||
699 | |||||
700 | # Pad with zeroes to equal length | ||||
701 | if ( length($b) > length($a) ) { | ||||
702 | $a .= '0' x ( length($b) - length($a) ); | ||||
703 | } | ||||
704 | elsif ( length($a) > length($b) ) { | ||||
705 | $b .= '0' x ( length($a) - length($b) ); | ||||
706 | } | ||||
707 | return ( $a, $b ); | ||||
708 | } | ||||
709 | |||||
710 | =begin TML | ||||
711 | |||||
712 | ---++ StaticMethod extractModuleVersion ($moduleName, $magic) -> ($moduleFound, $moduleVersion, $modulePath) | ||||
713 | |||||
714 | Locates a module in @INC and parses it to determine its version. If the second parameter is | ||||
715 | true, it magically handles Foswiki.pm's version construction. | ||||
716 | |||||
717 | Returns: | ||||
718 | $moduleFound - True if the module was found (and could be opended for read) | ||||
719 | $moduleVersion - The module version that was extracted, or undef if none was found. | ||||
720 | $modulePath - The full path to the module. | ||||
721 | |||||
722 | Require was used previously, but it doesn't scale and can have side-effects such a | ||||
723 | loading many unused dependencies, even LocalSite.cfg if it's a Foswiki module. | ||||
724 | |||||
725 | Since $VERSION is usually declared early in a module, we can also avoid reading | ||||
726 | most of (most) files. | ||||
727 | |||||
728 | This parser was inspired by Module::Extract::VERSION, though this is simplified and | ||||
729 | has special magic for the Foswiki build. | ||||
730 | |||||
731 | =cut | ||||
732 | |||||
733 | sub extractModuleVersion { | ||||
734 | my $module = shift; | ||||
735 | my $FoswikiPM = shift; | ||||
736 | |||||
737 | my $file = $module; | ||||
738 | $file =~ s,::,/,g; | ||||
739 | $file .= '.pm'; | ||||
740 | |||||
741 | # If module is available but no version, don't return undefined | ||||
742 | my $mod_version = '0'; | ||||
743 | my $mod_release = '0'; | ||||
744 | |||||
745 | foreach my $dir (@INC) { | ||||
746 | open( my $mf, '<', "$dir/$file" ) or next; | ||||
747 | local $/ = "\n"; | ||||
748 | local $_; | ||||
749 | my $pod; | ||||
750 | while (<$mf>) { | ||||
751 | chomp; | ||||
752 | if (/^=cut/) { | ||||
753 | $pod = 0; | ||||
754 | next; | ||||
755 | } | ||||
756 | if (/^=/) { | ||||
757 | $pod = 1; | ||||
758 | next; | ||||
759 | } | ||||
760 | next if ($pod); | ||||
761 | next if m/eval/; # Some modules issue $VERSION = eval $VERSION ... bypass that line | ||||
762 | s/\s*#.*$//; | ||||
763 | if ($FoswikiPM) { | ||||
764 | last if ( $mod_version && $mod_release ); | ||||
765 | if (/^\s*(?:our\s+)?\$(?:\w*::)*VERSION\s*=~\s*(.*?);/) { | ||||
766 | my $exp = $1; | ||||
767 | $exp =~ s/\$RELEASE/\$mod_release/g; | ||||
768 | eval("\$mod_version =~ $exp;"); | ||||
769 | die "1-Failed to eval $1 from $_ in $file at line $.: $@\n" | ||||
770 | if ($@); | ||||
771 | last; | ||||
772 | } | ||||
773 | |||||
774 | if ( | ||||
775 | /\$VERSION\s*=\s*version->(?:new|parse|declare)\s*\(\s*['"]([vV]?\d+\.\d+(?:\.\d+)?(?:_\d+)?)['"]\s*\)/ | ||||
776 | ) | ||||
777 | { | ||||
778 | $mod_version = $1; | ||||
779 | } | ||||
780 | if ( | ||||
781 | /^\s*(?:our\s+)?\$(?:\w*::)*(RELEASE|VERSION)\s*=(?!~)\s*(.*);/ | ||||
782 | ) | ||||
783 | { | ||||
784 | eval( "\$mod_" . lc($1) . " = $2;" ); | ||||
785 | die "2-Failed to eval $2 from $_ in $file at line $.: $@\n" | ||||
786 | if ($@); | ||||
787 | next; | ||||
788 | } | ||||
789 | next; | ||||
790 | } | ||||
791 | next unless (/^\s*(?:our\s+)?\$(?:\w*::)*VERSION\s*=\s*(.*?);/); | ||||
792 | eval("\$mod_version = $1;"); | ||||
793 | |||||
794 | # die "Failed to eval $1 from $_ in $file at line $. $@\n" if( $@ ); # DEBUG | ||||
795 | last; | ||||
796 | } | ||||
797 | close $mf; | ||||
798 | return ( 1, $mod_version, "$dir/$file", $mod_release ); | ||||
799 | } | ||||
800 | |||||
801 | return ( 0, undef ); | ||||
802 | } | ||||
803 | |||||
804 | =begin TML | ||||
805 | |||||
806 | ---++ StaticMethod checkPerlModules(@mods) | ||||
807 | |||||
808 | Examine the status of perl modules. Takes an array of references to hashes. | ||||
809 | Each module hash needs: | ||||
810 | name - e.g. Car::Wreck | ||||
811 | usage - description of what it's for | ||||
812 | disposition - 'required', 'recommended' | ||||
813 | minimumVersion - lowest acceptable $Module::VERSION | ||||
814 | |||||
815 | If the module is installed, the hash will be updated to add | ||||
816 | =installedVersion= - the version installed (or 'Unknown version' | ||||
817 | or 'Not installed') | ||||
818 | |||||
819 | The result of the check is written to the =check_result= field. | ||||
820 | |||||
821 | =cut | ||||
822 | |||||
823 | sub checkPerlModules { | ||||
824 | |||||
825 | foreach my $mod (@_) { | ||||
826 | |||||
827 | $mod->{minimumVersion} ||= 0; | ||||
828 | $mod->{disposition} ||= 'required'; | ||||
829 | $mod->{condition} ||= '>='; | ||||
830 | |||||
831 | my $type = $mod->{name} =~ m/^(Foswiki|TWiki)\b/ ? 'perl' : 'cpan'; | ||||
832 | |||||
833 | my $dep = Foswiki::Configure::Dependency->new( | ||||
834 | module => $mod->{name}, | ||||
835 | type => $type, | ||||
836 | version => $mod->{condition} . $mod->{minimumVersion}, | ||||
837 | ); | ||||
838 | my ( $ok, $msg ) = $dep->checkDependency(); | ||||
839 | |||||
840 | if ( $dep->{installed} ) { | ||||
841 | $mod->{installedVersion} = | ||||
842 | $dep->{installedVersion} || 'Unknown version'; | ||||
843 | $mod->{location} = $dep->{location}; | ||||
844 | $mod->{ok} = $ok; | ||||
845 | $mod->{check_result} = | ||||
846 | $mod->{name} . ' ' . $mod->{installedVersion} . ' installed'; | ||||
847 | unless ($ok) { | ||||
848 | $mod->{check_result} .= | ||||
849 | ' *Version ' | ||||
850 | . $mod->{minimumVersion} . ' ' | ||||
851 | . $mod->{disposition}; | ||||
852 | } | ||||
853 | $mod->{check_result} .= " for $mod->{usage}" if $mod->{usage}; | ||||
854 | $mod->{check_result} .= '*' unless $ok; | ||||
855 | $mod->{check_result} .= " $msg" | ||||
856 | if $msg | ||||
857 | && ( !$ok || $mod->{installedVersion} eq 'Unknown version' ); | ||||
858 | } | ||||
859 | else { | ||||
860 | $mod->{ok} = 0; | ||||
861 | $mod->{installedVersion} = 'Not installed'; | ||||
862 | $mod->{check_result} = | ||||
863 | $mod->{name} . ' is not installed. ' . $mod->{usage}; | ||||
864 | } | ||||
865 | } | ||||
866 | } | ||||
867 | |||||
868 | 1 | 16µs | 1; | ||
869 | __END__ |