--- /dev/null
+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
--- /dev/null
+Revision history for Lexical-Types
+
+0.01 2009-02-24 23:20 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+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
--- /dev/null
+--- #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
--- /dev/null
+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"
+ }
+);
--- /dev/null
+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.
+
--- /dev/null
+/* 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
--- /dev/null
+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
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+{
+ package Str;
+
+ sub TYPEDSCALAR { $_[1] = ' ' x 10 }
+}
+
+use Lexical::Types;
+
+my Str $x;
+
+print length($x), "\n"; # 10
--- /dev/null
+#!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" );
--- /dev/null
+#!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';
--- /dev/null
+#!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';
+}
--- /dev/null
+#!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';
--- /dev/null
+#!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';
+}
--- /dev/null
+#!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';
+}
--- /dev/null
+#!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';
+}
--- /dev/null
+#!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;
--- /dev/null
+#!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');
--- /dev/null
+#!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();
--- /dev/null
+#!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();
--- /dev/null
+#!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();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
projects / perl / modules / Lexical-Types.git / commitdiff