Mercurial > repo
diff interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/Exporter.pm @ 996:859f9b4339e6
<Gregor> tar xf egobot.tar.xz
author | HackBot |
---|---|
date | Sun, 09 Dec 2012 19:30:08 +0000 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/Exporter.pm Sun Dec 09 19:30:08 2012 +0000 @@ -0,0 +1,61 @@ +package Language::INTERCAL::Exporter; + +# Like the standard Exporter, but understand INTERCAL (per)version numbers + +# This file is part of CLC-INTERCAL + +# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved. + +# CLC-INTERCAL is copyrighted software. However, permission to use, modify, +# and distribute it is granted provided that the conditions set out in the +# licence agreement are met. See files README and COPYING in the distribution. + +use strict; +use vars qw($VERSION $PERVERSION); +($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Exporter.pm 1.-94.-2") =~ /\s(\S+)$/; + +use Carp; +require Exporter; +use vars qw(@EXPORT @EXPORT_OK); +@EXPORT = qw(import); +@EXPORT_OK = qw(is_intercal_number import require_version compare_version); + +sub is_intercal_number { + @_ == 1 or croak "Usage: is_intercal_number(STRING)"; + my ($s) = @_; + $s =~ /^-?\d+(?:\.-?\d+)*$/; +} + +sub import { + my $package = shift; + if (@_ && Language::INTERCAL::Exporter::is_intercal_number($_[0])) { + Language::INTERCAL::Exporter::require_version($package, shift); + } + unshift @_, $package; + goto &Exporter::import; +} + +sub require_version { + my ($package, $required) = @_; + $package = caller if ! defined $package; + no strict 'refs'; + my $provided = ((${"${package}::PERVERSION"} || '0') =~ /\s(\S+$)/)[0]; + compare_version($required, $provided) <= 0 + or croak "$package perversion $provided is too old (required $required)"; +} + +sub compare_version { + @_ == 2 or croak "Usage: compare_version(NUM, NUM)"; + my ($a, $b) = @_; + my @a = split(/\./, $a); + my @b = split(/\./, $b); + while (@a || @b) { + $a = @a ? shift @a : 0; + $b = @b ? shift @b : 0; + return -1 if $a < $b; + return 1 if $a > $b; + } + 0; +} + +1;