Telephone +44(0)1524 64544
Email: info(at)shadowcat.co.uk

Sat Dec 22 00:30:00 2012

Slides for the talk devel-declare at pgwest-2008

If you're reading this
on the web, remember
you may need to hit
Ctrl-minus to see the
longer lines of code

-

Adding keywords to
perl using perl

-

Matt S Trout
Shadowcat Systems

-

Lancaster
(NW England)

-

Catalyst
DBIx::Class

-

Catalyst
DBIx::Class
Moose

-

Object::Declare
(audreyt)

-

 column foo =>
   type is 'varchar',
   is required;

-

 column('foo',
   is->type('varchar'),
   required->is);

-

is::AUTOLOAD
UNIVERSAL::is

-

Clever

-

Too
Clever

-

sub is;

-

is(required)

-

*BOOM*

-

Better
way?

-

Better
syntax?

-

Source
filters?

-

Not Clever
At All

-

Perl
Compiler

-

Data::Alias

-

  alias $x = $y;
  alias {
    $x = $y;
  }

-

How does it
do it?

-

parser builds ops
context application
peephole optimiser

-

context
application

-

PL_check[]

-

PL_check[OP_RV2CV]

-

  dd_old_ck_rv2cv = PL_check[OP_RV2CV];
  PL_check[OP_RV2CV] = dd_ck_rv2cv;

-

  STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
     o = dd_old_ck_rv2cv(aTHX_ o);
     ...

-

RV2CV

-

  foo(...);

-

GV lookup:
  my $x = ${main::}{foo};

-

GV lookup:
  my $x = \*foo;

-

RV2CV:
  ${$x}{CODE}

-

  ${${main::}{foo}}{CODE}
  ->(...);

-

  foo(...);
     ^

-

  method foo ($foo) {
        ^

-

  scan_word()
  skipspace()

-

  foo
  Foo::Foo

-

  *foo = sub ...

-

  method foo ($foo) {

-

  scan_str()

-

  '...'
  q(...)
  /.../

-

  PL_lex_stuff

-

  *X = sub ...

-

  method foo X      {

-

Argument
injection

-

Tried
using
PADs

-

"Larry
wrote
that"

-

Larry
doesn't
remember

-

  PL_linestr

-

  method foo X {
    my ($self, $foo) = @_;

-

What if it
doesn't fit
in the SV?

-

Can't realloc
- perl has
char* pointers

-

C source
filter

-

  SvGROW(sv, 8192);

-

Don't have a
line longer
than this :)

-

no filters
on eval

-

PL_ppaddr

-

PL_ppaddr[]

-

  STATIC OP *dd_ck_entereval(pTHX_ OP *o) {
    ...
    o->op_ppaddr = dd_pp_entereval;

-

  OP* dd_pp_entereval(pTHX) {
    ...
    SvGROW(sv, 8192);
    ...
    return PL_ppaddr[OP_ENTEREVAL](aTHX);

-

  method ($foo) {

-

  method X {

-

Bare sub vs.
bracketed sub

-

  method()=X {
    my ($self, $foo) = @_;

-

  *method = sub :lvalue ...

-

... yeah ...

-

S_intuit_method

-

  if (package_exists) {
    'method';
  } elsif (sub_exists) {
    'sub';
  } else {
    'method';
  }

-

  method main {

-

  main->method {

-

No RV2CV

-

Lose :(

-

OP_CONST

-

  ${main::}{method}

-

  ${main::}{$const}

-

  method main {
        ^

-

OP_CONST:
  method ::main {

-

  ::main
  main::main

-

OP_RV2CV:
  method ::main { 
        ^

-

OP_RV2CV:
  method   main {

-

... yeah ...

-

Intermission

-

Talked to
Larry again

-

"There are 7 ways
for a compiler
to lie to itself"

-

He was wrong.

-

There -were-
7 ways

-

I think he
invented at
least 2 more

-

So maybe this
is number 10

-

"Rather you
than me"

-

... thanks

-

Anyway

-

OP_CONST

-

  method foo ($foo) {

-

  method {
    my ($self, $foo) = @_;

-

  *method = sub (&) {

-

C is for
performance

-

C API

-

  char* s = ...;
  char* new_s = skipspace(s);

-

perl API

-

  $offset;

-

  $offset;
  # s - SvPVX(PL_linestr)

-

  substr($linestr, $offset, 1)
  # *s

-

  $inc = toke_skipspace($offset);
  # new_s - s

-

  # s = skipspace(s);
  $offset += toke_skipspace($offset);

-

  toke_skipspace($offset);
  toke_scan_word($offset);

-

  method foo {
        ^

-

  $offset += toke_skipspace($offset);
  method foo {
         ^

-

  my $len = toke_scan_word($offset);
  method foo {
         ^  ^

-

  get_linestr()

-

  my $linestr = get_linestr;
  substr($linestr, $offset, $len);
  # 'foo'

-

  local $Offset;

-

  sub skipspace {
    $Offset += toke_skipspace($Offset);
  }

-

  sub skip_name {
    skipspace;
    if (my $len = toke_scan_word($Offset)) {
      my $linestr = get_linestr();
      my $name = substr($linestr, $Offset, $len);
      $Offset += $len;
      return $name;
    }
    return;
  }

-

  method foo {
  ->
  method {

-

  set_linestr()

-

  sub strip_name {
    skipspace;
    if (my $len = toke_scan_word($Offset)) {
      my $linestr = get_linestr();
      my $name = substr($linestr, $Offset, $len);
      substr($linestr, $Offset, $len) = '';
      set_linestr($linestr);
      return $name;
    }
    return;
  }

-

  method ($foo) {
         ^

-

  toke_skipspace($offset);
  toke_scan_word($offset);
  toke_scan_str($offset);

-

  get_lex_stuff()
  # return PL_lex_stuff

-

  clear_lex_stuff()
  # PL_lex_stuff = Nullsv

-

  sub strip_proto {
    skipspace;
    if (substr($linestr, $Offset, 1) eq '(') {
      my $len = toke_scan_str($Offset);
      my $proto = get_lex_stuff();
      clear_lex_stuff();
      ...

-

  sub parser {
    local ($Declarator, $Offset) = @_;
    skip_declarator;
    skipspace;
    my $name = strip_name;
    my $proto = strip_proto;

-

  method foo ($foo) {
  ->
  method {

-

  shadow_sub("package::name", $subref);

-

  PL_curstash

-

  HvNAME(PL_curstash)

-

  get_curstash_name()

-

  sub shadow { 
    my $pack = get_curstash_name;
    shadow_sub("${pack}::${Declarator}", $_[0]);
  }

-

  $name = join('::', Devel::Declare::get_curstash_name(), $name)
    unless ($name =~ /::/);
  shadow(sub (&) { no strict 'refs'; *{$name} = shift; });

-

  my $x = method () { ...

-

  shadow(sub (&) { shift });

-

Prototype
handling

-

  sub make_proto_unwrap
  # undef  -> my ($self) = shift;
  # ''     -> my ($self) = @_;
  # '$foo' -> my ($self, $foo) = @_;

-

  sub inject_if_block {
    my $inject = shift;
    skipspace;
    my $linestr = Devel::Declare::get_linestr;
    if (substr($linestr, $Offset, 1) eq '{') {
      substr($linestr, $Offset+1, 0) = $inject;
      Devel::Declare::set_linestr($linestr);
    }
  }

-

  method {
  ->
  method {my ($self ...

-

  inject_if_block(
    make_proto_unwrap($proto)
  );

-

  method foo { # declares __PACKAGE__::foo
  method My::foo { # declares My::foo
  method { # returns anon sub

-

  if (defined $name) {
    $name = join(
      '::', Devel::Declare::get_curstash_name(), $name
    ) unless ($name =~ /::/);
    shadow(
      sub (&) { no strict 'refs'; *{$name} = shift; }
    );
  } else {
    shadow(sub (&) { shift });
  }

-

  sub parser {
    local ($Declarator, $Offset) = @_;
    skip_declarator;
    my $name = strip_name;
    my $proto = strip_proto;
    inject_if_block(
      make_proto_unwrap($proto)
    );
    if (defined $name) {
      $name = join(
        '::', Devel::Declare::get_curstash_name(), $name
      ) unless ($name =~ /::/);
      shadow(
        sub (&) { no strict 'refs'; *{$name} = shift; }
      );
    } else {
      shadow(sub (&) { shift });
    }
  }

-

  package DeclareTest;

  sub method (&);

  BEGIN {
    Devel::Declare->setup_for(
      __PACKAGE__,
      { method =>
        { const => \&MethodHandlers::parser } }
    );
  }

-

  method new {
    my $class = ref $self || $self;
    return bless({ @_ }, $class);
  };

  method foo ($foo) {
    return (ref $self).': Foo: '.$foo;
  };

  method DeclareTest2::bar () {
    return 'DeclareTest2: bar';
  };

  $test_method2 = method ($what) {
    return join(', ', ref $self, $what);
  };

-

Still not
*quite*
a keyword

-

sub foo {
  ...
}

-

method foo {
  ...
};

-

Trailing
semicolon

-

Far too
easy to
forget

-

%^H

-

compiler
hints hash

-

  # block scope %^H
  $^H |= 0x120000;

-

  $^H{foo} = Scope::Guard->new(
    sub { ... }
  ); # fires at end of scope

-

  method foo {
    ...
  }
   ^

-

  my $linestr = Devel::Declare::get_linestr;
  my $offset = Devel::Declare::get_linestr_offset;
  substr($linestr, $offset, 0) = ';';
  Devel::Declare::set_linestr($linestr);

-

  method foo {
    ...
  };
   ^

-

  sub inject_scope {
    $^H |= 0x120000;
    $^H{DD_METHODHANDLERS} = Scope::Guard->new(sub {
      my $linestr = Devel::Declare::get_linestr;
      my $offset = Devel::Declare::get_linestr_offset;
      substr($linestr, $offset, 0) = ';';
      Devel::Declare::set_linestr($linestr);
    });
  }

-

  sub scope_injector_call {
    return ' BEGIN { MethodHandlers::inject_scope }; ';
  }

-

  my $inject = make_proto_unwrap($proto);
  if (defined $name) {
    $inject = scope_injector_call().$inject;
  }
  inject_if_block($inject);

-

  sub parser {
    local ($Declarator, $Offset) = @_;
    skip_declarator;
    my $name = strip_name;
    my $proto = strip_proto;
    my $inject = make_proto_unwrap($proto);
    if (defined $name) {
      $inject = scope_injector_call().$inject;
    }
    inject_if_block($inject);
    if (defined $name) {
      $name = join(
        '::', Devel::Declare::get_curstash_name(), $name
      ) unless ($name =~ /::/);
      shadow(
        sub (&) { no strict 'refs'; *{$name} = shift; }
      );
    } else {
      shadow(sub (&) { shift });
    }
  }

-

  method new {
    my $class = ref $self || $self;
    return bless({ @_ }, $class);
  }

  method foo ($foo) {
    return (ref $self).': Foo: '.$foo;
  }

  method DeclareTest2::bar () {
    return 'DeclareTest2: bar';
  }

  $test_method2 = method ($what) {
    return join(', ', ref $self, $what);
  };

-

Caveats

-

OP_CONSTs get
made from
other places

-

  "method"
          ^

-

  scan_str()
  PL_lex_stuff

-

  if (!PL_lex_stuff)

-

There may be
other places we
-don't- handle

-

Send failing
tests if you
find one :)

-

If you mess up, you'll
probably just get
"Syntax error"

-

  # This is your friend:
  warn get_linestr();

-

strip_name and
friends aren't
a real API yet

-

It builds and works
on most 5.8.1+ perls

-

... but not
all just yet.

-

If the tests
pass, it should
work fine

-

If they don't,
tell me!

-

Documentation
quite thin

-

osfameron is
going to help
me fix that

-

But it
works!

-

Reaction
uses it

-

Method::Signatures
uses it

-

Sub::Curried
uses it

-

Come find me
on IRC if you
do anything
cool with it

-

mst -at- shadowcat.co.uk
http://www.shadowcat.co.uk/

irc.perl.org #moose

-

END