335 lines
10 KiB
Perl
335 lines
10 KiB
Perl
|
##
|
||
|
|
## OSSP uuid - Universally Unique Identifier
|
||
|
|
## Copyright (c) 2004-2007 Ralf S. Engelschall <rse@engelschall.com>
|
||
|
|
## Copyright (c) 2004-2007 The OSSP Project <http://www.ossp.org/>
|
||
|
|
##
|
||
|
|
## This file is part of OSSP uuid, a library for the generation
|
||
|
|
## of UUIDs which can found at http://www.ossp.org/pkg/lib/uuid/
|
||
|
|
##
|
||
|
|
## Permission to use, copy, modify, and distribute this software for
|
||
|
|
## any purpose with or without fee is hereby granted, provided that
|
||
|
|
## the above copyright notice and this permission notice appear in all
|
||
|
|
## copies.
|
||
|
|
##
|
||
|
|
## THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
|
||
|
|
## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||
|
|
## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||
|
|
## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
|
||
|
|
## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||
|
|
## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||
|
|
## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
|
||
|
|
## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
|
||
|
|
## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
|
||
|
|
## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
|
||
|
|
## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||
|
|
## SUCH DAMAGE.
|
||
|
|
##
|
||
|
|
## uuid.pm: Perl Binding (Perl part)
|
||
|
|
##
|
||
|
|
|
||
|
|
##
|
||
|
|
## High-Level Perl Module TIE-style API
|
||
|
|
## (just a functionality-reduced TIE wrapper around the OO-style API)
|
||
|
|
##
|
||
|
|
|
||
|
|
package OSSP::uuid::tie;
|
||
|
|
|
||
|
|
use 5.008;
|
||
|
|
use strict;
|
||
|
|
use warnings;
|
||
|
|
use Carp;
|
||
|
|
|
||
|
|
# inhert from Tie::Scalar
|
||
|
|
require Tie::Scalar;
|
||
|
|
our @ISA = qw(Tie::Scalar);
|
||
|
|
|
||
|
|
# helper function
|
||
|
|
sub mode_sanity {
|
||
|
|
my ($mode) = @_;
|
||
|
|
if (not ( defined($mode)
|
||
|
|
and ref($mode) eq 'ARRAY'
|
||
|
|
and ( (@{$mode} == 1 and $mode->[0] =~ m|^v[14]$|)
|
||
|
|
or (@{$mode} == 3 and $mode->[0] =~ m|^v[35]$|)))) {
|
||
|
|
return (undef, "invalid UUID generation mode specification");
|
||
|
|
}
|
||
|
|
if ($mode->[0] =~ m|^v[35]$|) {
|
||
|
|
my $uuid_ns = new OSSP::uuid;
|
||
|
|
$uuid_ns->load($mode->[1])
|
||
|
|
or return (undef, "failed to load UUID $mode->[0] namespace");
|
||
|
|
$mode->[1] = $uuid_ns;
|
||
|
|
}
|
||
|
|
return ($mode, undef);
|
||
|
|
}
|
||
|
|
|
||
|
|
# constructor
|
||
|
|
sub TIESCALAR {
|
||
|
|
my ($class, @args) = @_;
|
||
|
|
my $self = {};
|
||
|
|
bless ($self, $class);
|
||
|
|
$self->{-uuid} = new OSSP::uuid
|
||
|
|
or croak "failed to create OSSP::uuid object";
|
||
|
|
my ($mode, $error) = mode_sanity(defined($args[0]) ? [ @args ] : [ "v1" ]);
|
||
|
|
croak $error if defined($error);
|
||
|
|
$self->{-mode} = $mode;
|
||
|
|
return $self;
|
||
|
|
}
|
||
|
|
|
||
|
|
# destructor
|
||
|
|
sub DESTROY {
|
||
|
|
my ($self) = @_;
|
||
|
|
delete $self->{-uuid};
|
||
|
|
delete $self->{-mode};
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# fetch value from scalar
|
||
|
|
# (applied semantic: export UUID in string format)
|
||
|
|
sub FETCH {
|
||
|
|
my ($self) = @_;
|
||
|
|
$self->{-uuid}->make(@{$self->{-mode}})
|
||
|
|
or croak "failed to generate new UUID";
|
||
|
|
my $value = $self->{-uuid}->export("str")
|
||
|
|
or croak "failed to export new UUID";
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
# store value into scalar
|
||
|
|
# (applied semantic: configure new UUID generation mode)
|
||
|
|
sub STORE {
|
||
|
|
my ($self, $value) = @_;
|
||
|
|
my ($mode, $error) = mode_sanity($value);
|
||
|
|
croak $error if defined($error);
|
||
|
|
$self->{-mode} = $mode;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
##
|
||
|
|
## High-Level Perl Module OO-style API
|
||
|
|
## (just an OO wrapper around the C-style API)
|
||
|
|
##
|
||
|
|
|
||
|
|
package OSSP::uuid;
|
||
|
|
|
||
|
|
use 5.008;
|
||
|
|
use strict;
|
||
|
|
use warnings;
|
||
|
|
use Carp;
|
||
|
|
use XSLoader;
|
||
|
|
use Exporter;
|
||
|
|
|
||
|
|
# API version
|
||
|
|
our $VERSION = do { my @v = ('1.6.2' =~ m/\d+/g); sprintf("%d.".("%02d"x$#v), @v); };
|
||
|
|
|
||
|
|
# API inheritance
|
||
|
|
our @ISA = qw(Exporter);
|
||
|
|
|
||
|
|
# API symbols
|
||
|
|
my $symbols = {
|
||
|
|
'const' => [qw(
|
||
|
|
UUID_VERSION
|
||
|
|
UUID_LEN_BIN
|
||
|
|
UUID_LEN_STR
|
||
|
|
UUID_LEN_SIV
|
||
|
|
UUID_RC_OK
|
||
|
|
UUID_RC_ARG
|
||
|
|
UUID_RC_MEM
|
||
|
|
UUID_RC_SYS
|
||
|
|
UUID_RC_INT
|
||
|
|
UUID_RC_IMP
|
||
|
|
UUID_MAKE_V1
|
||
|
|
UUID_MAKE_V3
|
||
|
|
UUID_MAKE_V4
|
||
|
|
UUID_MAKE_V5
|
||
|
|
UUID_MAKE_MC
|
||
|
|
UUID_FMT_BIN
|
||
|
|
UUID_FMT_STR
|
||
|
|
UUID_FMT_SIV
|
||
|
|
UUID_FMT_TXT
|
||
|
|
)],
|
||
|
|
'func' => [qw(
|
||
|
|
uuid_create
|
||
|
|
uuid_destroy
|
||
|
|
uuid_load
|
||
|
|
uuid_make
|
||
|
|
uuid_isnil
|
||
|
|
uuid_compare
|
||
|
|
uuid_import
|
||
|
|
uuid_export
|
||
|
|
uuid_error
|
||
|
|
uuid_version
|
||
|
|
)]
|
||
|
|
};
|
||
|
|
|
||
|
|
# API symbol exportation
|
||
|
|
our %EXPORT_TAGS = (
|
||
|
|
'all' => [ @{$symbols->{'const'}}, @{$symbols->{'func'}} ],
|
||
|
|
'const' => [ @{$symbols->{'const'}} ],
|
||
|
|
'func' => [ @{$symbols->{'func'}} ]
|
||
|
|
);
|
||
|
|
our @EXPORT_OK = @{$EXPORT_TAGS{'all'}};
|
||
|
|
our @EXPORT = ();
|
||
|
|
|
||
|
|
# constructor
|
||
|
|
sub new {
|
||
|
|
my $proto = shift;
|
||
|
|
my $class = ref($proto) || $proto;
|
||
|
|
my $self = {};
|
||
|
|
bless ($self, $class);
|
||
|
|
$self->{-uuid} = undef;
|
||
|
|
$self->{-rc} = $self->UUID_RC_OK;
|
||
|
|
my $rc = uuid_create($self->{-uuid});
|
||
|
|
if ($rc != $self->UUID_RC_OK) {
|
||
|
|
croak(sprintf("OSSP::uuid::new: uuid_create: %s (%d)", uuid_error($rc), $rc));
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
return $self;
|
||
|
|
}
|
||
|
|
|
||
|
|
# destructor
|
||
|
|
sub DESTROY ($) {
|
||
|
|
my ($self) = @_;
|
||
|
|
$self->{-rc} = uuid_destroy($self->{-uuid}) if (defined($self->{-uuid}));
|
||
|
|
if ($self->{-rc} != $self->UUID_RC_OK) {
|
||
|
|
carp(sprintf("OSSP::uuid::DESTROY: uuid_destroy: %s (%d)", uuid_error($self->{-rc}), $self->{-rc}));
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
$self->{-uuid} = undef;
|
||
|
|
$self->{-rc} = undef;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub load ($$) {
|
||
|
|
my ($self, $name) = @_;
|
||
|
|
$self->{-rc} = uuid_load($self->{-uuid}, $name);
|
||
|
|
return ($self->{-rc} == $self->UUID_RC_OK);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub make ($$;@) {
|
||
|
|
my ($self, $mode, @valist) = @_;
|
||
|
|
my $mode_code = 0;
|
||
|
|
foreach my $spec (split(/,/, $mode)) {
|
||
|
|
if ($spec eq 'v1') { $mode_code |= $self->UUID_MAKE_V1; }
|
||
|
|
elsif ($spec eq 'v3') { $mode_code |= $self->UUID_MAKE_V3; }
|
||
|
|
elsif ($spec eq 'v4') { $mode_code |= $self->UUID_MAKE_V4; }
|
||
|
|
elsif ($spec eq 'v5') { $mode_code |= $self->UUID_MAKE_V5; }
|
||
|
|
elsif ($spec eq 'mc') { $mode_code |= $self->UUID_MAKE_MC; }
|
||
|
|
else { croak("invalid mode specification \"$spec\""); }
|
||
|
|
}
|
||
|
|
if (($mode_code & $self->UUID_MAKE_V3) or ($mode_code & $self->UUID_MAKE_V5)) {
|
||
|
|
if (not (ref($valist[0]) and $valist[0]->isa("OSSP::uuid"))) {
|
||
|
|
croak("UUID_MAKE_V3/UUID_MAKE_V5 requires namespace argument to be OSSP::uuid object");
|
||
|
|
}
|
||
|
|
my $ns = $valist[0]->{-uuid};
|
||
|
|
my $name = $valist[1];
|
||
|
|
$self->{-rc} = uuid_make($self->{-uuid}, $mode_code, $ns, $name);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$self->{-rc} = uuid_make($self->{-uuid}, $mode_code);
|
||
|
|
}
|
||
|
|
return ($self->{-rc} == $self->UUID_RC_OK);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub isnil ($) {
|
||
|
|
my ($self) = @_;
|
||
|
|
my $result;
|
||
|
|
$self->{-rc} = uuid_isnil($self->{-uuid}, $result);
|
||
|
|
return ($self->{-rc} == $self->UUID_RC_OK ? $result : undef);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub compare ($$) {
|
||
|
|
my ($self, $other) = @_;
|
||
|
|
my $result = 0;
|
||
|
|
if (not (ref($other) and $other->isa("OSSP::uuid"))) {
|
||
|
|
croak("argument has to an OSSP::uuid object");
|
||
|
|
}
|
||
|
|
$self->{-rc} = uuid_compare($self->{-uuid}, $other->{-uuid}, $result);
|
||
|
|
return ($self->{-rc} == $self->UUID_RC_OK ? $result : undef);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub import {
|
||
|
|
# ATTENTION: The OSSP uuid API function "import" conflicts with
|
||
|
|
# the standardized "import" method the Perl world expects from
|
||
|
|
# their modules. In order to keep the Perl binding consist
|
||
|
|
# with the C API, we solve the conflict under run-time by
|
||
|
|
# distinguishing between the two types of "import" calls.
|
||
|
|
if (defined($_[0]) and ref($_[0]) =~ m/^OSSP::uuid/) {
|
||
|
|
# the regular OSSP::uuid "import" method
|
||
|
|
croak("import method expects 3 or 4 arguments") if (@_ < 3 or @_ > 4); # emulate prototype
|
||
|
|
my ($self, $fmt, $data_ptr, $data_len) = @_;
|
||
|
|
if ($fmt eq 'bin') { $fmt = $self->UUID_FMT_BIN; }
|
||
|
|
elsif ($fmt eq 'str') { $fmt = $self->UUID_FMT_STR; }
|
||
|
|
elsif ($fmt eq 'siv') { $fmt = $self->UUID_FMT_SIV; }
|
||
|
|
elsif ($fmt eq 'txt') { $fmt = $self->UUID_FMT_TXT; }
|
||
|
|
else { croak("invalid format \"$fmt\""); }
|
||
|
|
$data_len ||= length($data_ptr); # functional redudant, but Perl dislikes undef value here
|
||
|
|
$self->{-rc} = uuid_import($self->{-uuid}, $fmt, $data_ptr, $data_len);
|
||
|
|
return ($self->{-rc} == $self->UUID_RC_OK);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
# the special Perl "import" method
|
||
|
|
# (usually inherited from the Exporter)
|
||
|
|
no strict "refs";
|
||
|
|
return OSSP::uuid->export_to_level(1, @_);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub export {
|
||
|
|
# ATTENTION: The OSSP uuid API function "export" conflicts with
|
||
|
|
# the standardized "export" method the Perl world expects from
|
||
|
|
# their modules. In order to keep the Perl binding consist
|
||
|
|
# with the C API, we solve the conflict under run-time by
|
||
|
|
# distinguishing between the two types of "export" calls.
|
||
|
|
if (defined($_[0]) and ref($_[0]) =~ m/^OSSP::uuid/) {
|
||
|
|
# the regular OSSP::uuid "export" method
|
||
|
|
croak("export method expects 2 arguments") if (@_ != 2); # emulate prototype
|
||
|
|
my ($self, $fmt) = @_;
|
||
|
|
my $data_ptr;
|
||
|
|
if ($fmt eq 'bin') { $fmt = $self->UUID_FMT_BIN; }
|
||
|
|
elsif ($fmt eq 'str') { $fmt = $self->UUID_FMT_STR; }
|
||
|
|
elsif ($fmt eq 'siv') { $fmt = $self->UUID_FMT_SIV; }
|
||
|
|
elsif ($fmt eq 'txt') { $fmt = $self->UUID_FMT_TXT; }
|
||
|
|
else { croak("invalid format \"$fmt\""); }
|
||
|
|
$self->{-rc} = uuid_export($self->{-uuid}, $fmt, $data_ptr, undef);
|
||
|
|
return ($self->{-rc} == $self->UUID_RC_OK ? $data_ptr : undef);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
# the special Perl "export" method
|
||
|
|
# (usually inherited from the Exporter)
|
||
|
|
return Exporter::export(@_);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub error ($;$) {
|
||
|
|
my ($self, $rc) = @_;
|
||
|
|
$rc = $self->{-rc} if (not defined($rc));
|
||
|
|
return wantarray ? (uuid_error($rc), $rc) : uuid_error($rc);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub version (;$) {
|
||
|
|
my ($self) = @_;
|
||
|
|
return uuid_version();
|
||
|
|
}
|
||
|
|
|
||
|
|
##
|
||
|
|
## Low-Level Perl XS C-style API
|
||
|
|
## (actually just the activation of the XS part)
|
||
|
|
##
|
||
|
|
|
||
|
|
# auto-loading constants
|
||
|
|
sub AUTOLOAD {
|
||
|
|
my $constname;
|
||
|
|
our $AUTOLOAD;
|
||
|
|
($constname = $AUTOLOAD) =~ s/.*:://;
|
||
|
|
croak "&OSSP::uuid::constant not defined" if ($constname eq 'constant');
|
||
|
|
my ($error, $val) = constant($constname);
|
||
|
|
croak $error if ($error);
|
||
|
|
{ no strict 'refs'; *$AUTOLOAD = sub { $val }; }
|
||
|
|
goto &$AUTOLOAD;
|
||
|
|
}
|
||
|
|
|
||
|
|
# static-loading functions
|
||
|
|
XSLoader::load('OSSP::uuid', $VERSION);
|
||
|
|
|
||
|
|
1;
|
||
|
|
|