t/23-scalar-object.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 {
   7  package Lexical::Types::Test::Str;
   8
   9  use overload '.'      => \&_concat,
  10               '""'     => \&_interpolate,
  11               'cmp'    => \&_cmp,
  12               fallback => 1;
  13
  14  sub new {
  15   my ($class, $buf) = @_;
  16   $class = ref($class) || $class;
  17   unless (defined $buf) {
  18    $buf = '';
  19   } elsif ($buf->isa($class)) {
  20    $buf = $buf->{buffer};
  21   }
  22   bless { buffer => $buf }, $class;
  23  }
  24
  25  sub _concat {
  26   my ($self, $str, $r) = @_;
  27   $self->new($r ? $str . $self->{buffer} : $self->{buffer} . $str);
  28  }
  29
  30  sub _interpolate { shift->{buffer} }
  31
  32  sub _cmp {
  33   my ($a, $b, $r) = @_;
  34   my $bufa = ref($a) ? $a->{buffer} : $a;
  35   my $bufb = ref($b) ? $b->{buffer} : $b;
  36   my $res = $bufa cmp $bufb;
  37   $res = -$res if $r;
  38   return $res;
  39  }
  40
  41  sub _typedscalar { __PACKAGE__->new() }
  42 }
  43
  44 {
  45  package Str;
  46 }
  47
  48 use Test::More tests => 2 * 6;
  49
  50 use Lexical::Types as => sub {
  51  return 'Lexical::Types::Test::' . $_[0],
  52         '_' . lc($_[1])
  53 };
  54
  55 for (1 .. 2) {
  56  my Str $x;
  57
  58  isa_ok $x,   'Lexical::Types::Test::Str', '$x';
  59  is     "$x", '',                          '$x contains the right thing';
  60
  61  $x .= "foo";
  62  isa_ok $x,   'Lexical::Types::Test::Str', '$x . "foo"';
  63  is     "$x", 'foo',                       '$x . "foo" contains the right thing';
  64
  65  $x = "bar" . $x;
  66  isa_ok $x,   'Lexical::Types::Test::Str', '"bar" . $x';
  67  is     "$x", 'barfoo',                    '"bar" . $x contains the right thing';
  68 }