From b9203ee84953006547f4afd58f405874c87bf0dc Mon Sep 17 00:00:00 2001 From: Daniel Wilhelm Date: Fri, 18 Apr 2014 17:02:17 +0200 Subject: 3.1 --- shared/ossp_uuid/perl/uuid.pm | 334 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 334 insertions(+) create mode 100644 shared/ossp_uuid/perl/uuid.pm (limited to 'shared/ossp_uuid/perl/uuid.pm') diff --git a/shared/ossp_uuid/perl/uuid.pm b/shared/ossp_uuid/perl/uuid.pm new file mode 100644 index 00000000..b3223966 --- /dev/null +++ b/shared/ossp_uuid/perl/uuid.pm @@ -0,0 +1,334 @@ +## +## OSSP uuid - Universally Unique Identifier +## Copyright (c) 2004-2007 Ralf S. Engelschall +## Copyright (c) 2004-2007 The OSSP Project +## +## 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; + -- cgit