← Index
NYTProf Performance Profile   « line view »
For ./view
  Run on Fri Jul 31 18:42:36 2015
Reported on Fri Jul 31 18:48:14 2015

Filename/var/www/foswikidev/core/lib/Foswiki/Configure/Dependency.pm
StatementsExecuted 36 statements in 3.22ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11117µs63µsFoswiki::Configure::Dependency::::BEGIN@20Foswiki::Configure::Dependency::BEGIN@20
11114µs26µsFoswiki::Configure::Dependency::::BEGIN@17Foswiki::Configure::Dependency::BEGIN@17
11110µs34µsFoswiki::Configure::Dependency::::BEGIN@22Foswiki::Configure::Dependency::BEGIN@22
1119µs13µsFoswiki::Configure::Dependency::::BEGIN@18Foswiki::Configure::Dependency::BEGIN@18
0000s0sFoswiki::Configure::Dependency::::_compare_cpan_versionsFoswiki::Configure::Dependency::_compare_cpan_versions
0000s0sFoswiki::Configure::Dependency::::_compare_extension_versionsFoswiki::Configure::Dependency::_compare_extension_versions
0000s0sFoswiki::Configure::Dependency::::_decodeReleaseStringFoswiki::Configure::Dependency::_decodeReleaseString
0000s0sFoswiki::Configure::Dependency::::_digitise_tuplesFoswiki::Configure::Dependency::_digitise_tuples
0000s0sFoswiki::Configure::Dependency::::checkDependencyFoswiki::Configure::Dependency::checkDependency
0000s0sFoswiki::Configure::Dependency::::checkPerlModulesFoswiki::Configure::Dependency::checkPerlModules
0000s0sFoswiki::Configure::Dependency::::compare_using_cpan_versionFoswiki::Configure::Dependency::compare_using_cpan_version
0000s0sFoswiki::Configure::Dependency::::compare_versionsFoswiki::Configure::Dependency::compare_versions
0000s0sFoswiki::Configure::Dependency::::extractModuleVersionFoswiki::Configure::Dependency::extractModuleVersion
0000s0sFoswiki::Configure::Dependency::::newFoswiki::Configure::Dependency::new
0000s0sFoswiki::Configure::Dependency::::studyInstallationFoswiki::Configure::Dependency::studyInstallation
Call graph for these subroutines as a Graphviz dot language file.
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
7This module defines a dependency required by a Foswiki module and provides
8functions to test if the dependency is installed, and compare versions with
9the required version.
10
11It is also used to examine the installed version of a Foswiki module.
12
13=cut
14
15package Foswiki::Configure::Dependency;
16
17226µs238µ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
use strict;
# spent 26µs making 1 call to Foswiki::Configure::Dependency::BEGIN@17 # spent 12µs making 1 call to strict::import
18235µs217µ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
use warnings;
# spent 13µs making 1 call to Foswiki::Configure::Dependency::BEGIN@18 # spent 4µs making 1 call to warnings::import
19
20355µs3109µ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
use version 0.77;
# 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
2222.99ms258µ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
use Assert;
# spent 34µs making 1 call to Foswiki::Configure::Dependency::BEGIN@22 # spent 24µs making 1 call to Exporter::import
23
2413µsmy @MNAMES = qw(jan feb mar apr may jun jul aug sep oct nov dec);
2512µsmy $mnamess = join( '|', @MNAMES );
26115µsmy $MNAME = qr/$mnamess/i;
271200nsmy %M2N;
281312µsforeach ( 0 .. $#MNAMES ) { $M2N{ $MNAMES[$_] } = $_ + 1; }
29
3015µsmy %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
461200nsmy $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
5711µsmy $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
681900nsmy $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
751700nsmy $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
801700nsmy $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
90118µsmy $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
102114µsmy $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
115122µsmy $LAX = qr/ $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
116
117#--------------------------------------------------------------------------#
118
119=begin TML
120
121---++ ClassMethod new( %opts )
122
123Create 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
142sub 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
173Check 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
180sub 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.
187Please check it manually and install if necessary.
188LALA
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}
196TINKYWINKY
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}
209PO
210 }
211 }
212 return ( 1, <<DIPSY );
213$this->{module} version $this->{installedRelease} installed
214DIPSY
215}
216
217=begin TML
218
219---++ ObjectMethod studyInstallation()
220
221Check 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
229sub 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
276sub 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
298sub 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
313sub _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 =~
362s/(\d+)$separator($MNAME)$separator(\d+)/$3.$separator.$M2N{ lc($2) }.$separator.$1/ge;
363 $b =~
364s/(\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
437sub _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
598sub _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.
681sub _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
714Locates a module in @INC and parses it to determine its version. If the second parameter is
715true, it magically handles Foswiki.pm's version construction.
716
717Returns:
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
722Require was used previously, but it doesn't scale and can have side-effects such a
723loading many unused dependencies, even LocalSite.cfg if it's a Foswiki module.
724
725Since $VERSION is usually declared early in a module, we can also avoid reading
726most of (most) files.
727
728This parser was inspired by Module::Extract::VERSION, though this is simplified and
729has special magic for the Foswiki build.
730
731=cut
732
733sub 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
808Examine the status of perl modules. Takes an array of references to hashes.
809Each 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
815If the module is installed, the hash will be updated to add
816=installedVersion= - the version installed (or 'Unknown version'
817or 'Not installed')
818
819The result of the check is written to the =check_result= field.
820
821=cut
822
823sub 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
868116µs1;
869__END__