From: Vincent Pit <vince@profvince.com>
Date: Tue, 24 Feb 2009 23:11:59 +0000 (+0100)
Subject: Initial import
X-Git-Tag: v0.01~1
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=commitdiff_plain;h=06cb3f3506161a118dc440264dcabcd612b9432c

Initial import
---

06cb3f3506161a118dc440264dcabcd612b9432c
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0bf743a
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,25 @@
+blib*
+pm_to_blib*
+
+Makefile
+Makefile.old
+Build
+_build*
+
+*.tar.gz
+Lexical-Types-*
+
+core.*
+*.[co]
+*.so
+*.bs
+*.out
+*.def
+*.exp
+
+cover_db
+*.gcda
+*.gcov
+*.gcno
+
+Debian_CPANTS.txt
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..8a5efa1
--- /dev/null
+++ b/Changes
@@ -0,0 +1,5 @@
+Revision history for Lexical-Types
+
+0.01    2009-02-24 23:20 UTC
+        First version, released on an unsuspecting world.
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..79a39dc
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,20 @@
+Changes
+MANIFEST
+META.yml
+Makefile.PL
+README
+Types.xs
+lib/Lexical/Types.pm
+samples/basic.pl
+t/00-load.t
+t/10-args.t
+t/11-integrate.t
+t/20-object.t
+t/21-tie.t
+t/22-magic.t
+t/30-threads.t
+t/90-boilerplate.t
+t/91-pod.t
+t/92-pod-coverage.t
+t/95-portability-files.t
+t/99-kwalitee.t
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..d0319e4
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,30 @@
+--- #YAML:1.0
+name:               Lexical-Types
+version:            0.01
+abstract:           Extend the semantics of typed lexicals.
+author:
+    - Vincent Pit <perl@profvince.com>
+license:            perl
+distribution_type:  module
+configure_requires:
+    ExtUtils::MakeMaker:  0
+build_requires:
+    ExtUtils::MakeMaker:  0
+    Test::More:           0
+requires:
+    Carp:      0
+    perl:      5.008
+    XSLoader:  0
+resources:
+    bugtracker:  http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Lexical-Types
+    homepage:    http://search.cpan.org/dist/Lexical-Types/
+    license:     http://dev.perl.org/licenses/
+    repository:  http://git.profvince.com/perl/modules/Lexical-Types.git
+no_index:
+    directory:
+        - t
+        - inc
+generated_by:       ExtUtils::MakeMaker version 6.48
+meta-spec:
+    url:      http://module-build.sourceforge.net/META-spec-v1.4.html
+    version:  1.4
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..710fb1e
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,45 @@
+use 5.008;
+
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+my $dist = 'Lexical-Types';
+
+my %META = (
+ configure_requires => {
+  'ExtUtils::MakeMaker' => 0,
+ },
+ build_requires => {
+  'ExtUtils::MakeMaker' => 0,
+  'Test::More'          => 0,
+ },
+ resources => {
+  bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist",
+  homepage   => "http://search.cpan.org/dist/$dist/",
+  license    => 'http://dev.perl.org/licenses/',
+  repository => "http://git.profvince.com/perl/modules/$dist.git",
+ },
+);
+
+WriteMakefile(
+    NAME             => 'Lexical::Types',
+    AUTHOR           => 'Vincent Pit <perl@profvince.com>',
+    LICENSE          => 'perl',
+    VERSION_FROM     => 'lib/Lexical/Types.pm',
+    ABSTRACT_FROM    => 'lib/Lexical/Types.pm',
+    PL_FILES         => {},
+    PREREQ_PM        => {
+        'Carp'          => 0,
+        'XSLoader'      => 0,
+    },
+    MIN_PERL_VERSION => 5.008,
+    META_MERGE       => \%META,
+    dist             => {
+        PREOP    => 'pod2text lib/Lexical/Types.pm > $(DISTVNAME)/README',
+        COMPRESS => 'gzip -9f', SUFFIX => 'gz'
+    },
+    clean            => {
+        FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
+    }
+);
diff --git a/README b/README
new file mode 100644
index 0000000..6e144ad
--- /dev/null
+++ b/README
@@ -0,0 +1,127 @@
+NAME
+    Lexical::Types - Extend the semantics of typed lexicals.
+
+VERSION
+    Version 0.01
+
+SYNOPSIS
+        {
+         package Str;
+
+         sub TYPEDSCALAR { Some::String::Implementation->new }
+        }
+
+        use Lexical::Types;
+
+        my Str $x; # $x is now a Some::String::Implementation object
+
+DESCRIPTION
+    This module allows you to hook the execution of typed lexicals
+    declarations ("my Foo $x"). In particular, it can be used to
+    automatically tie or bless typed lexicals.
+
+    It is not implemented with a source filter.
+
+FUNCTIONS
+  "import [ as => [ $prefix | $mangler ] ]"
+    Magically called when writing "use Lexical::Types". All the occurences
+    of "my Foo $x" in the current lexical scope will be changed to call at
+    each run a given method in a given package. The method and package are
+    determined by the parameter "as" :
+
+    *   If it's left unspecified, the "TYPEDSCALAR" method in the "Foo"
+        package will be called.
+
+            use Lexical::Types;
+            my Str $x; # calls Str->TYPEDSCALAR
+
+    *   If a plain scalar $prefix is passed as the value, the "TYPEDSCALAR"
+        method in the "${prefix}::Foo" package will be used.
+
+            use Lexical::Types as => 'My::'; # or "as => 'My'"
+            my Str $x; # calls My::Str->TYPEDSCALAR
+
+    *   If the value given is a code reference $mangler, it will be called
+        at compile-time with arguments 'Foo' and 'TYPEDSCALAR' and is
+        expected to return the desired package and method name (in that
+        order). If any of those is "undef", the default value will be used
+        instead.
+
+            use Lexical::Types as => sub { 'My', 'new_' . lc($_[0]) };
+            my Str $x; # the coderef indicates to call My->new_str
+
+    The initializer method receives an alias to the pad entry of $x in $_[1]
+    and the original type name ("Foo") in $_[2]. You can either edit $_[1]
+    in place, in which case you should return an empty list, or return a new
+    scalar that will be copied into $x.
+
+  "unimport"
+    Magically called when writing "no Lexical::Types". Turns the module off.
+
+INTEGRATION
+    You can integrate Lexical::Types in your module so that using it will
+    provide types to your users without asking them to load either
+    Lexical::Types or the type classes manually.
+
+        package MyTypes;
+
+        BEGIN { require Lexical::Types; }
+
+        sub import {
+         eval 'package Str; package Int'; # The types you want to support
+         Lexical::Types->import(
+          as => sub { __PACKAGE__, 'new_' . lc($_[0]) }
+         );
+        }
+
+        sub unimport {
+         Lexical::Types->unimport;
+        }
+
+        sub new_str { ... }
+
+        sub new_int { ... }
+
+CAVEATS
+    For "perl" to be able to parse "my Foo $x", the package "Foo" must be
+    defined somewhere, and this even if you use the "as" option to redirect
+    to another package. It's unlikely to find a workaround, as this happens
+    deep inside the lexer, far from the reach of an extension.
+
+    Only one mangler or prefix can be in use at the same time in a given
+    scope.
+
+DEPENDENCIES
+    perl 5.8, XSLoader.
+
+SEE ALSO
+    fields.
+
+    Attribute::Handlers.
+
+AUTHOR
+    Vincent Pit, "<perl at profvince.com>", <http://www.profvince.com>.
+
+    You can contact me by mail or on "irc.perl.org" (vincent).
+
+BUGS
+    Please report any bugs or feature requests to "bug-lexical-types at
+    rt.cpan.org", or through the web interface at
+    <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Lexical-Types>. I will
+    be notified, and then you'll automatically be notified of progress on
+    your bug as I make changes.
+
+SUPPORT
+    You can find documentation for this module with the perldoc command.
+
+        perldoc Lexical::Types
+
+ACKNOWLEDGEMENTS
+    Inspired by Ricardo Signes.
+
+COPYRIGHT & LICENSE
+    Copyright 2009 Vincent Pit, all rights reserved.
+
+    This program is free software; you can redistribute it and/or modify it
+    under the same terms as Perl itself.
+
diff --git a/Types.xs b/Types.xs
new file mode 100644
index 0000000..ebfb8a7
--- /dev/null
+++ b/Types.xs
@@ -0,0 +1,273 @@
+/* This file is part of the Lexical-Types Perl module.
+ * See http://search.cpan.org/dist/Lexical-Types/ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* --- Compatibility wrappers ---------------------------------------------- */
+
+#define LT_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
+
+#if LT_HAS_PERL(5, 10, 0) || defined(PL_parser)
+# ifndef PL_in_my_stash
+#  define PL_in_my_stash PL_parser->in_my_stash
+# endif
+#else
+# ifndef PL_in_my_stash
+#  define PL_in_my_stash PL_Iin_my_stash
+# endif
+#endif
+
+#ifndef Newx
+# define Newx(v, n, c) New(0, v, n, c)
+#endif
+
+#ifndef HvNAME_get
+# define HvNAME_get(H) HvNAME(H)
+#endif
+
+#ifndef HvNAMELEN_get
+# define HvNAMELEN_get(H) strlen(HvNAME_get(H))
+#endif
+
+#define __PACKAGE__     "Lexical::Types"
+#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
+
+/* --- Helpers ------------------------------------------------------------- */
+
+/* ... Hints ............................................................... */
+
+STATIC U32 lt_hash = 0;
+
+STATIC SV *lt_hint(pTHX) {
+#define lt_hint() lt_hint(aTHX)
+ SV *id;
+#if LT_HAS_PERL(5, 10, 0)
+ id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+                                     NULL,
+                                     __PACKAGE__, __PACKAGE_LEN__,
+                                     0,
+                                     lt_hash);
+#else
+ SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, lt_hash);
+ if (!val)
+  return 0;
+ id = *val;
+#endif
+ return (id && SvOK(id)) ? id : NULL;
+}
+
+/* ... op => info map ...................................................... */
+
+#define OP2STR_BUF char buf[(CHAR_BIT * sizeof(UV)) / 2]
+#define OP2STR(O)  (sprintf(buf, "%"UVxf, PTR2UV(O)))
+
+STATIC HV *lt_op_map = NULL;
+
+typedef struct {
+ SV *orig_pkg;
+ SV *type_pkg;
+ SV *type_meth;
+ OP *(*pp_padsv)(pTHX);
+} lt_op_info;
+
+STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) {
+#define lt_map_store(O, P1, P2, M, PP) lt_map_store(aTHX_ (O), (P1), (P2), (M), (PP))
+ OP2STR_BUF;
+ SV *val;
+ lt_op_info *oi;
+
+ Newx(oi, 1, lt_op_info);
+ oi->orig_pkg  = orig_pkg;
+ oi->type_pkg  = type_pkg;
+ oi->type_meth = type_meth;
+ oi->pp_padsv  = pp_padsv;
+ val = newSVuv(PTR2UV(oi));
+
+ (void)hv_store(lt_op_map, buf, OP2STR(o), val, 0);
+}
+
+STATIC const lt_op_info *lt_map_fetch(pTHX_ const OP *o) {
+#define lt_map_fetch(O) lt_map_fetch(aTHX_ (O))
+ OP2STR_BUF;
+ SV **svp;
+
+ svp = hv_fetch(lt_op_map, buf, OP2STR(o), 0);
+
+ return svp ? INT2PTR(const lt_op_info *, SvUVX(*svp)) : NULL;
+}
+
+/* --- Hooks --------------------------------------------------------------- */
+
+/* ... Our pp_padsv ........................................................ */
+
+STATIC OP *(*lt_old_pp_padsv)(pTHX) = 0;
+
+STATIC OP *lt_pp_padsv(pTHX) {
+ const lt_op_info *oi;
+
+ if ((PL_op->op_private & OPpLVAL_INTRO) && (oi = lt_map_fetch(PL_op))) {
+  PADOFFSET targ = PL_op->op_targ;
+  SV *sv         = PAD_SVl(targ);
+
+  if (sv) {
+   int items;
+   dSP;
+
+   ENTER;
+   SAVETMPS;
+
+   PUSHMARK(SP);
+   EXTEND(SP, 3);
+   PUSHs(sv_2mortal(newSVsv(oi->type_pkg)));
+   PUSHs(sv);
+   PUSHs(sv_2mortal(newSVsv(oi->orig_pkg)));
+   PUTBACK;
+
+   items = call_sv(oi->type_meth, G_ARRAY | G_METHOD);
+
+   SPAGAIN;
+   switch (items) {
+    case 0:
+     break;
+    case 1:
+     sv_setsv(sv, POPs);
+     break;
+    default:
+     croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
+   }
+   PUTBACK;
+
+   FREETMPS;
+   LEAVE;
+  }
+
+  return CALL_FPTR(oi->pp_padsv)(aTHX);
+ }
+
+ return CALL_FPTR(lt_old_pp_padsv)(aTHX);
+}
+
+/* ... Our ck_pad{any,sv} .................................................. */
+
+/* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
+ * function, but are instead manually mutated from a PADANY. This is why we set
+ * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
+ * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
+ * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
+ * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
+ * globally. */
+
+STATIC U32 lt_TYPEDSCALAR_hash = 0; 
+
+STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
+
+STATIC OP *lt_ck_padany(pTHX_ OP *o) {
+ HV *stash;
+ SV *hint;
+
+ PL_ppaddr[OP_PADSV] = lt_old_pp_padsv;
+
+ o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
+
+ stash = PL_in_my_stash;
+ if (stash && (hint = lt_hint())) {
+  SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
+  SV *orig_meth = newSVpvn_share("TYPEDSCALAR", 11, lt_TYPEDSCALAR_hash);
+  SV *type_pkg  = orig_pkg;
+  SV *type_meth = orig_meth;
+  SV *code      = INT2PTR(SV *, SvUVX(hint));
+
+  SvREADONLY_on(orig_pkg);
+  SvREADONLY_on(orig_meth);
+
+  if (code) {
+   int items;
+   dSP;
+
+   ENTER;
+   SAVETMPS;
+
+   PUSHMARK(SP);
+   EXTEND(SP, 2);
+   PUSHs(orig_pkg);
+   PUSHs(orig_meth);
+   PUTBACK;
+
+   items = call_sv(code, G_ARRAY);
+
+   SPAGAIN;
+   if (items > 2)
+    croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
+   if (items) {
+    SV *rsv;
+    if (items > 1) {
+     rsv = POPs;
+     if (SvOK(rsv))
+      type_meth = newSVsv(rsv);
+    }
+    rsv = POPs;
+    if (SvOK(rsv))
+     type_pkg = newSVsv(rsv);
+   }
+   PUTBACK;
+
+   FREETMPS;
+   LEAVE;
+  }
+
+  lt_old_pp_padsv     = PL_ppaddr[OP_PADSV];
+  lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_old_pp_padsv);
+  PL_ppaddr[OP_PADSV] = lt_pp_padsv;
+ }
+
+ return o;
+}
+
+STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
+
+STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
+ PL_ppaddr[OP_PADSV] = lt_old_pp_padsv;
+ return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
+}
+
+STATIC U32 lt_initialized = 0;
+
+/* --- XS ------------------------------------------------------------------ */
+
+MODULE = Lexical::Types      PACKAGE = Lexical::Types
+
+PROTOTYPES: DISABLE
+
+BOOT: 
+{                                    
+ if (!lt_initialized++) {
+  PERL_HASH(lt_TYPEDSCALAR_hash, "TYPEDSCALAR", 11);
+
+  PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
+  lt_op_map = newHV();
+
+  lt_old_ck_padany    = PL_check[OP_PADANY];
+  PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
+  lt_old_ck_padsv     = PL_check[OP_PADSV];
+  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
+  lt_old_pp_padsv     = PL_ppaddr[OP_PADSV];
+ }
+}
+
+SV *_tag(SV *ref)
+PREINIT:
+ SV *ret;
+CODE:
+ if (SvOK(ref) && SvROK(ref)) {
+  SV *sv = SvRV(ref);
+  SvREFCNT_inc(sv);
+  ret = newSVuv(PTR2UV(sv));
+ } else {
+  ret = newSVuv(0);
+ }
+ RETVAL = ret;
+OUTPUT:
+ RETVAL
diff --git a/lib/Lexical/Types.pm b/lib/Lexical/Types.pm
new file mode 100644
index 0000000..4eed8be
--- /dev/null
+++ b/lib/Lexical/Types.pm
@@ -0,0 +1,194 @@
+package Lexical::Types;
+
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+
+=head1 NAME
+
+Lexical::Types - Extend the semantics of typed lexicals.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION;
+BEGIN {
+ $VERSION = '0.01';
+}
+
+=head1 SYNOPSIS
+
+    {
+     package Str;
+
+     sub TYPEDSCALAR { Some::String::Implementation->new }
+    }
+
+    use Lexical::Types;
+
+    my Str $x; # $x is now a Some::String::Implementation object
+
+=head1 DESCRIPTION
+
+This module allows you to hook the execution of typed lexicals declarations (C<my Foo $x>).
+In particular, it can be used to automatically tie or bless typed lexicals.
+
+It is B<not> implemented with a source filter.
+
+=cut
+
+BEGIN {
+ require XSLoader;
+ XSLoader::load(__PACKAGE__, $VERSION);
+}
+
+=head1 FUNCTIONS
+
+=head2 C<< import [ as => [ $prefix | $mangler ] ] >>
+
+Magically called when writing C<use Lexical::Types>.
+All the occurences of C<my Foo $x> in the current lexical scope will be changed to call at each run a given method in a given package.
+The method and package are determined by the parameter C<as> :
+
+=over 4
+
+=item *
+
+If it's left unspecified, the C<TYPEDSCALAR> method in the C<Foo> package will be called.
+
+    use Lexical::Types;
+    my Str $x; # calls Str->TYPEDSCALAR
+
+=item *
+
+If a plain scalar C<$prefix> is passed as the value, the C<TYPEDSCALAR> method in the C<${prefix}::Foo> package will be used.
+
+    use Lexical::Types as => 'My::'; # or "as => 'My'"
+    my Str $x; # calls My::Str->TYPEDSCALAR
+
+=item *
+
+If the value given is a code reference C<$mangler>, it will be called at compile-time with arguments C<'Foo'> and C<'TYPEDSCALAR'> and is expected to return the desired package and method name (in that order).
+If any of those is C<undef>, the default value will be used instead.
+
+    use Lexical::Types as => sub { 'My', 'new_' . lc($_[0]) };
+    my Str $x; # the coderef indicates to call My->new_str
+
+=back
+
+The initializer method receives an alias to the pad entry of C<$x> in C<$_[1]> and the original type name (C<Foo>) in C<$_[2]>.
+You can either edit C<$_[1]> in place, in which case you should return an empty list, or return a new scalar that will be copied into C<$x>.
+
+=cut
+
+sub import {
+ shift;
+ my %args = @_;
+
+ my $hint;
+
+ my $as = delete $args{'as'};
+ if ($as) {
+  my $r = ref $as;
+  if ($r eq 'CODE') {
+   $hint = _tag($as);
+  } elsif (!$r) {
+   $as .= '::' if $as !~ /::$/;
+   $hint = _tag(sub { $as . $_[0] });
+  } else {
+   croak "Invalid $r reference for 'as'";
+  }
+ } else {
+  $hint = _tag(0);
+ }
+
+ $^H |= 0x020000;
+ # Yes, we store a coderef inside the hints hash, but that's just for compile
+ # time.
+ $^H{+(__PACKAGE__)} = $hint;
+}
+
+=head2 C<unimport>
+
+Magically called when writing C<no Lexical::Types>.
+Turns the module off.
+
+=cut
+
+sub unimport {
+ $^H{+(__PACKAGE__)} = undef;
+}
+
+=head1 INTEGRATION
+
+You can integrate L<Lexical::Types> in your module so that using it will provide types to your users without asking them to load either L<Lexical::Types> or the type classes manually.
+
+    package MyTypes;
+
+    BEGIN { require Lexical::Types; }
+
+    sub import {
+     eval 'package Str; package Int'; # The types you want to support
+     Lexical::Types->import(
+      as => sub { __PACKAGE__, 'new_' . lc($_[0]) }
+     );
+    }
+
+    sub unimport {
+     Lexical::Types->unimport;
+    }
+
+    sub new_str { ... }
+
+    sub new_int { ... }
+
+=head1 CAVEATS
+
+For C<perl> to be able to parse C<my Foo $x>, the package C<Foo> must be defined somewhere, and this even if you use the C<as> option to redirect to another package.
+It's unlikely to find a workaround, as this happens deep inside the lexer, far from the reach of an extension.
+
+Only one mangler or prefix can be in use at the same time in a given scope.
+
+=head1 DEPENDENCIES
+
+L<perl> 5.8, L<XSLoader>.
+
+=head1 SEE ALSO
+
+L<fields>.
+
+L<Attribute::Handlers>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-lexical-types at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Lexical-Types>.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+    perldoc Lexical::Types
+
+=head1 ACKNOWLEDGEMENTS
+
+Inspired by Ricardo Signes.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2009 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of Lexical::Types
diff --git a/samples/basic.pl b/samples/basic.pl
new file mode 100644
index 0000000..e35d852
--- /dev/null
+++ b/samples/basic.pl
@@ -0,0 +1,16 @@
+#!perl
+
+use strict;
+use warnings;
+
+{
+ package Str;
+
+ sub TYPEDSCALAR { $_[1] = ' ' x 10 }
+}
+
+use Lexical::Types;
+
+my Str $x;
+
+print length($x), "\n"; # 10
diff --git a/t/00-load.t b/t/00-load.t
new file mode 100644
index 0000000..83dcc0b
--- /dev/null
+++ b/t/00-load.t
@@ -0,0 +1,12 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+BEGIN {
+	use_ok( 'Lexical::Types' );
+}
+
+diag( "Testing Lexical::Types $Lexical::Types::VERSION, Perl $], $^X" );
diff --git a/t/10-args.t b/t/10-args.t
new file mode 100644
index 0000000..dddcea9
--- /dev/null
+++ b/t/10-args.t
@@ -0,0 +1,106 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 11 + 6;
+
+{
+ package Lexical::Types::Test::LTT;
+
+ sub TYPEDSCALAR {
+  $_[1] = (caller(0))[2];
+  Test::More::is($_[2], 'LTT', 'original type is ok');
+  ();
+ }
+
+ no warnings 'once';
+ *TS = \&TYPEDSCALAR;
+}
+
+{
+ package Lexical::Types::Test::LTT2;
+
+ sub TYPEDSCALAR { 1 .. 2 }
+}
+
+{
+ package LTT;
+ 
+ no warnings 'once';
+ *ts = \&Lexical::Types::Test::LTT::TYPEDSCALAR
+}
+
+{
+ use Lexical::Types as => 'Lexical::Types::Test';
+ my LTT $x;
+ is $x, __LINE__-1, 'as => string, without trailing ::';
+
+ no Lexical::Types;
+ my LTT $y;
+ is $y, undef, 'after no';
+}
+
+{
+ use Lexical::Types as => 'Lexical::Types::Test::';
+ my LTT $x;
+ is $x, __LINE__-1, 'as => string, with trailing ::';
+}
+
+{
+ use Lexical::Types as => sub { 'Lexical::Types::Test::LTT' };
+ my LTT $x;
+ is $x, __LINE__-1, 'as => code, returning package name';
+}
+
+{
+ use Lexical::Types as => sub { 'Lexical::Types::Test::LTT', undef };
+ my LTT $x;
+ is $x, __LINE__-1, 'as => code, returning package name and undef';
+}
+
+{
+ use Lexical::Types as => sub { undef, 'ts' };
+ my LTT $x;
+ is $x, __LINE__-1, 'as => code, returning undef and method name';
+}
+
+{
+ use Lexical::Types as => sub { 'Lexical::Types::Test::LTT', 'TS' };
+ my LTT $x;
+ is $x, __LINE__-1, 'as => code, returning package and method name';
+}
+
+{
+ my $expect = qr/^Invalid ARRAY reference/;
+ local $@;
+ eval q[
+  use Lexical::Types as => [ qw/a b c/ ];
+  my LTT $x;
+ ];
+ like $@, $expect, 'as => array';
+}
+
+{
+ my $expect = qr/^Lexical::Types mangler should return zero, one or two scalars, but got 3/;
+ diag 'This will throw two warnings' if $] >= 5.008008 and $] < 5.009;
+ local $@;
+ eval q[
+  use Lexical::Types as => sub { qw/a b c/ };
+  my LTT $x;
+ ];
+ like $@, $expect, 'as => code, returning three scalars';
+}
+
+{
+ my $expect = qr/^Typed scalar initializer method should return zero or one scalar, but got 2/;
+ local $@;
+ eval q[
+  use Lexical::Types as => sub { 'Lexical::Types::Test::LTT2' };
+  my LTT $x;
+ ];
+ like $@, $expect, 'as => code, initializing by returning two scalars';
+}
+
+my LTT $x;
+is $x, undef, 'out of scope';
diff --git a/t/11-integrate.t b/t/11-integrate.t
new file mode 100644
index 0000000..3b32ff1
--- /dev/null
+++ b/t/11-integrate.t
@@ -0,0 +1,55 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 5 + 4;
+
+{
+ package MyTypes;
+
+ BEGIN { require Lexical::Types; }
+
+ sub import {
+  eval 'package Str; package Int';
+  Lexical::Types->import(
+   as => sub { __PACKAGE__, 'new_' . lc($_[0]) }
+  );
+ }
+
+ sub unimport {
+  Lexical::Types->unimport;
+ }
+
+ sub new_str {
+  $_[1] = 'str:' . (caller(0))[2];
+  Test::More::is($_[2], 'Str', 'original type is correct');
+  ();
+ }
+
+ sub new_int {
+  $_[1] = (caller(0))[2];
+  Test::More::is($_[2], 'Int', 'original type is correct');
+  ();
+ }
+}
+
+{
+ BEGIN { MyTypes->import }
+ my Str $x;
+ is $x, 'str:' . (__LINE__-1), 'MyTypes->new_str 1';
+ {
+  BEGIN { MyTypes->unimport }
+  my Str $y;
+  is $y, undef, 'pragma not in use';
+  {
+   BEGIN { MyTypes->import }
+   my Int $z;
+   is $z, __LINE__-1, 'MyTypes->new_int 1';
+  }
+ }
+ my Str $y;
+ is $y, 'str:' . (__LINE__-1), 'MyTypes->new_str 2';
+ my Int $z;
+ is $z, __LINE__-1, 'MyTypes->new_int 2';
+}
diff --git a/t/12-padsv.t b/t/12-padsv.t
new file mode 100644
index 0000000..aedf744
--- /dev/null
+++ b/t/12-padsv.t
@@ -0,0 +1,27 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use File::Spec;
+
+use Test::More tests => 3;
+
+sub Str::TYPEDSCALAR {
+ my $buf = (caller(0))[2];
+ open $_[1], '<', \$buf;
+ ()
+}
+
+use Lexical::Types;
+
+my Str $x;
+our $r = <$x>;
+is $r, __LINE__-2, 'trick for our - readline';
+
+my Str $y;
+my $s = <$y>;
+is $s, __LINE__-2, 'trick for my - readline';
+
+my $z = 7;
+is $z, 7, 'trick for others';
diff --git a/t/20-object.t b/t/20-object.t
new file mode 100644
index 0000000..60cbb76
--- /dev/null
+++ b/t/20-object.t
@@ -0,0 +1,68 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+{
+ package Lexical::Types::Test::Str;
+
+ use overload '.'      => \&_concat,
+              '""'     => \&_interpolate,
+              'cmp'    => \&_cmp,
+              fallback => 1;
+
+ sub new {
+  my ($class, $buf) = @_;
+  $class = ref($class) || $class;
+  unless (defined $buf) {
+   $buf = '';
+  } elsif ($buf->isa($class)) {
+   $buf = $buf->{buffer};
+  }
+  bless { buffer => $buf }, $class;
+ }
+
+ sub _concat {
+  my ($self, $str, $r) = @_;
+  $self->new($r ? $str . $self->{buffer} : $self->{buffer} . $str);
+ }
+
+ sub _interpolate { shift->{buffer} }
+
+ sub _cmp {
+  my ($a, $b, $r) = @_;
+  my $bufa = ref($a) ? $a->{buffer} : $a;
+  my $bufb = ref($b) ? $b->{buffer} : $b;
+  my $res = $bufa cmp $bufb;
+  $res = -$res if $r;
+  return $res;
+ }
+
+ sub _typedscalar { __PACKAGE__->new() }
+}
+
+{
+ package Str;
+}
+
+use Test::More tests => 2 * 6;
+
+use Lexical::Types as => sub {
+ return 'Lexical::Types::Test::' . $_[0],
+        '_' . lc($_[1])
+};
+
+for (1 .. 2) {
+ my Str $x;
+
+ isa_ok $x,   'Lexical::Types::Test::Str', '$x';
+ is     "$x", '',                          '$x contains the right thing';
+
+ $x .= "foo";
+ isa_ok $x,   'Lexical::Types::Test::Str', '$x . "foo"';
+ is     "$x", 'foo',                       '$x . "foo" contains the right thing';
+
+ $x = "bar" . $x;
+ isa_ok $x,   'Lexical::Types::Test::Str', '"bar" . $x';
+ is     "$x", 'barfoo',                    '"bar" . $x contains the right thing';
+}
diff --git a/t/21-tie.t b/t/21-tie.t
new file mode 100644
index 0000000..a72ce66
--- /dev/null
+++ b/t/21-tie.t
@@ -0,0 +1,51 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+{
+ package Lexical::Types::Test::Str;
+
+ sub TIESCALAR {
+  my ($class, $buf) = @_;
+  $class = ref($class) || $class;
+  unless (defined $buf) {
+   $buf = '';
+  } elsif ($buf->isa($class)) {
+   $buf = $buf->{buffer};
+  }
+  bless { buffer => $buf }, $class;
+ }
+
+ sub FETCH { shift->{buffer} }
+
+ sub STORE {
+  my ($self, $val) = @_;
+  $self->{buffer} = (ref($val) && $val->isa(ref($self))) ? $val->{buffer}
+                                                         : $val;
+ }
+
+ sub TYPEDSCALAR { tie $_[1], __PACKAGE__; () }
+}
+
+{ package Str; }
+
+use Test::More tests => 2 * 6;
+
+use Lexical::Types as => 'Lexical::Types::Test';
+
+for (1 .. 2) {
+ my Str $x = "abc";
+
+ is ref(tied($x)), 'Lexical::Types::Test::Str', '$x';
+ is "$x",          'abc',                       '$x contains the right thing';
+
+ $x .= "foo";
+ is ref(tied($x)), 'Lexical::Types::Test::Str', '$x . "foo"';
+ is "$x",          'abcfoo',                    '$x . "foo" contains the right thing';
+
+ my Str $y = "bar" . $x;
+
+ is ref(tied($y)), 'Lexical::Types::Test::Str', '$y';
+ is "$y",          'barabcfoo',                 '$y contains the right thing';
+}
diff --git a/t/22-magic.t b/t/22-magic.t
new file mode 100644
index 0000000..d421253
--- /dev/null
+++ b/t/22-magic.t
@@ -0,0 +1,67 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ plan skip_all => 'Variable::Magic required to test magic'
+                                      unless eval "use Variable::Magic 0.31; 1";
+}
+
+{
+ package Lexical::Types::Test::Str;
+
+ use Variable::Magic qw/wizard cast/;
+
+ our $wiz;
+ BEGIN {
+  $wiz = wizard data => sub { +{ } },
+                get  => sub { ++$_[1]->{get}; () },
+                set  => sub { ++$_[1]->{set}; () };
+ }
+ 
+ sub TYPEDSCALAR { cast $_[1], $wiz, $_[2]; () }
+}
+
+{ package Str; }
+
+BEGIN {
+ plan tests => 2 * 6;
+}
+
+use Lexical::Types as => 'Lexical::Types::Test';
+
+sub check (&$$;$) {
+ my $got = Variable::Magic::getdata($_[1], $Lexical::Types::Test::Str::wiz);
+ my ($test, $exp, $desc) = @_[0, 2, 3];
+ my $want = wantarray;
+ my @ret;
+ {
+  local @{$got}{qw/get set/}; delete @{$got}{qw/get set/};
+  if ($want) {
+   @ret = eval { $test->() };
+  } elsif (defined $want) {
+   $ret[0] = eval { $test->() };
+  } else {
+   eval { $test->() };
+  }
+  is_deeply $got, $exp, $desc;
+ }
+ return $want ? @ret : $ret[0];
+}
+
+for (1 .. 2) {
+ my Str $x = "abc";
+
+ my $y = check { "$x" } $x, { get => 1 }, 'interpolate';
+ is $y, 'abc', 'interpolate correctly';
+
+ check { $x .= "foo" } $x, { get => 1, set => 1 }, 'append';
+ is $x, 'abcfoo', 'append correctly';
+
+ my Str $z;
+ check { $z = "bar" . $x } $z, { set => 1 }, 'scalar assign';
+ is $z, 'barabcfoo', 'scalar assign correctly';
+}
diff --git a/t/30-threads.t b/t/30-threads.t
new file mode 100644
index 0000000..d3dcc3b
--- /dev/null
+++ b/t/30-threads.t
@@ -0,0 +1,39 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Config qw/%Config/;
+
+BEGIN {
+ if (!$Config{useithreads}) {
+  require Test::More;
+  Test::More->import;
+  plan(skip_all => 'This perl wasn\'t built to support threads');
+ }
+}
+
+use threads;
+
+use Test::More tests => 10 * 2;
+
+{
+ package Lexical::Types::Test::Tag;
+
+ sub TYPEDSCALAR { $_[1] = threads->tid() }
+}
+
+{ package Tag; }
+
+use Lexical::Types as => 'Lexical::Types::Test::';
+
+sub try {
+ for (1 .. 2) {
+  my Tag $t;
+  my $tid = threads->tid();
+  is $t, $tid, "typed lexical correctly initialized at run $_ in thread $tid";
+ }
+}
+
+my @t = map threads->create(\&try), 1 .. 10;
+$_->join for @t;
diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t
new file mode 100644
index 0000000..e6f7c7c
--- /dev/null
+++ b/t/90-boilerplate.t
@@ -0,0 +1,48 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+    my ($filename, %regex) = @_;
+    open( my $fh, '<', $filename )
+        or die "couldn't open $filename for reading: $!";
+
+    my %violated;
+
+    while (my $line = <$fh>) {
+        while (my ($desc, $regex) = each %regex) {
+            if ($line =~ $regex) {
+                push @{$violated{$desc}||=[]}, $.;
+            }
+        }
+    }
+
+    if (%violated) {
+        fail("$filename contains boilerplate text");
+        diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+    } else {
+        pass("$filename contains no boilerplate text");
+    }
+}
+
+sub module_boilerplate_ok {
+    my ($module) = @_;
+    not_in_file_ok($module =>
+        'the great new $MODULENAME'   => qr/ - The great new /,
+        'boilerplate description'     => qr/Quick summary of what the module/,
+        'stub function definition'    => qr/function[12]/,
+    );
+}
+
+not_in_file_ok(README =>
+  "The README is used..."       => qr/The README is used/,
+  "'version information here'"  => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+  "placeholder date/time"       => qr(Date/time)
+);
+
+module_boilerplate_ok('lib/Lexical/Types.pm');
diff --git a/t/91-pod.t b/t/91-pod.t
new file mode 100644
index 0000000..ee8b18a
--- /dev/null
+++ b/t/91-pod.t
@@ -0,0 +1,12 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t
new file mode 100644
index 0000000..a3086aa
--- /dev/null
+++ b/t/92-pod-coverage.t
@@ -0,0 +1,18 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
+
+all_pod_coverage_ok();
diff --git a/t/95-portability-files.t b/t/95-portability-files.t
new file mode 100644
index 0000000..ab541f3
--- /dev/null
+++ b/t/95-portability-files.t
@@ -0,0 +1,10 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Portability::Files";
+plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@;
+run_tests();
diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t
new file mode 100644
index 0000000..7775e60
--- /dev/null
+++ b/t/99-kwalitee.t
@@ -0,0 +1,9 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;