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