Class-CompiledC2.23/0000755000076500007650000000000010654642147014450 5ustar bladeblade00000000000000Class-CompiledC2.23/Class-CompiledC/0000755000076500007650000000000010654642147017352 5ustar bladeblade00000000000000Class-CompiledC2.23/Class-CompiledC/Changes0000744000076500007650000000117110654641744020650 0ustar bladeblade00000000000000Revision history for Perl extension Class::CompiledC. 2.20 Thu Oct 26 21:46:28 CEST 2006 @865 /Internet Time/ first public release. 2.21 Fri Oct 27 23:25:25 CEST 2006 @934 /Internet Time/ I had some extranous parens in Makefile.pl, now at least Makefile.pl should run now. 2.22 Sun Oct 29 22:53:54 CET 2006 @954 /Internet Time/ updated documentation, minor code cleanups. 2.23 Fri Aug 03 16:08:26 CEST 2007 @630 /Internet Time/ added a prefix to variable named c functions to avoid nameclashes with perls internal and the c standard lib. documentation updates. Class-CompiledC2.23/Class-CompiledC/lib/0000755000076500007650000000000010654642147020120 5ustar bladeblade00000000000000Class-CompiledC2.23/Class-CompiledC/lib/Class/0000755000076500007650000000000010654642147021165 5ustar bladeblade00000000000000Class-CompiledC2.23/Class-CompiledC/lib/Class/CompiledC.pm0000744000076500007650000013573010654641612023370 0ustar bladeblade00000000000000package Class::CompiledC; =head1 NAME Class::CompiledC =cut use 5.008007; use strict; use warnings; use Carp; use base qw/Attribute::Handlers/; use Inline; use Exporter qw/import/; =head1 VERSION This document describes version 2.23 of Class::CompiledC, released Fri Aug 03 16:08:04 CEST 2007 @630 /Internet Time/ =cut our $VERSION = 2.23; our %includes; our %funcs; our %extfuncs; our %code; our %scheduled; our %types; our %EXPORT_TAGS; our @EXPORT_OK; our $re_ft; our $re_ft_isa; sub __circumPrint($$$); sub __include; sub __baseref($$); sub __hashref($); sub __arrayref($); sub __coderef($); sub __fetchSymbolName($); sub __promoteFieldTypeToMacro($); sub __parseFieldType; $re_ft = qr/^(?:\s*)(int|float|number|string|ref|arrayref|hashref| coderef|object|regexpref|any|uint)(?:\s*)/xi; $re_ft_isa = qr/^(?:\s*)isa(?:\s*)\((?:\s*)([\w:]*)(?:\s*)\)(?:\s*)/i; =head1 ABSTRACT Class::CompiledC -- use C structs for your objects. =head1 SYNOPSIS package Foo; use strict; use warnings; use base qw/Class::CompiledC/; sub type : Field(String); sub data : Field(Hashref); sub count : Field(Int); sub callback : Field(Coderef); sub size : Field(Float); sub dontcare : Field(Number); sub dumper : Field(Isa(Data::Dumper)); sub items : Field(Arrayref); sub notsure : Field(Object); my $x; $x = Foo->new(-type => "example", -data => {}, -count => 0, -callback => sub { print "j p " ^ " a h " ^ " " x 4 while 1}, -size => 138.4, -dontcare => 12, -dumper => Data::Dumper->new, -items => [qw/coffee cigarettes beer/], -notsure => SomeClass->new ); =head1 DESCRIPTION Note: Documentation is incomplete, partly outdated, of poor style and full of typos. I need a ghostwriter. Class::CompiledC creates classes which are based on C structs, it does this by generating C code and compiling the code when your module is compiled (1). You can add constraints on the type of the data that can be stored in the instance variables of your objects by specifiying a C (i call instance variables fields because it's shorter). A field without constraints are declared by using the C<: Field> attribute (2) on a subroutine stub (3) of the name you would like to have for your field eg. C this would generate a field called 'foo' and it's accesor method, also called 'foo' If you want to add a constraint to the field just name the type as a parameter for the attribute eg C. (1) I<(actually, Class::CompiledC utilizes L to do the dirty work; L uses L to do it's job and L employes your C compiler to compile the code. This means you need Inline Inline::C and a working C compiler on the runtime machine.> (2) I perl6 calls them traits or properties; see L not to confuse with instance variables (fields) which are sometimes also called attributes; terms differ from language to language and perlmodules use all of them with different meanings, very confusing> (3) I see L> I TODO =head2 Supported Field Types The following Field types are currently supported by Class::CompiledC =head3 Any sub Foo : Field(Any) NOOP. Does nothing, is even optimized away at compile time. You can use it to explicitly declare that you don't care. =head3 Arrayref sub Foo : Field(Arrayref) Ensures that the field can only hold a reference to an array. (beside the always legal undefined value). =head3 Coderef sub Foo : Field(Coderef) Ensures that the field can only hold a reference to some kind of subroutine. (beside the always legal undefined value). =head3 Float sub Foo : Field(Float) Ensures that the field can only hold a valid floating point value. (An int is also a valid floating point value, as is undef). =head3 Hashref sub Foo : Field(Hashref) Ensures that the field can only hold a reference to a hash. (beside the always legal undefined value). =head3 Int sub Foo : Field(Int) Ensures that the field can only hold a valid integer value. (beside the always legal undefined value). =head3 Isa sub Foo : Field(Isa(Some::Class)) Ensures that the field can only hold a reference to a object of the specified class, or a subclass of it. (beside the always legal undefined value). (The relationship is determined the same way as the Cisa> method) =head3 Number sub Foo : Field(Number) At current this just an alias for the C type, but that may change. =head3 Object sub Foo : Field(Object) Ensures that the field can only hold a reference to a object. (beside the always legal undefined value). =head3 Ref sub Foo : Field(Ref) Ensures that the field can only hold a reference to something. (beside the always legal undefined value). =head3 Regexpref sub Foo : Field(Regexpref) Ensures that the field can only hold a reference to a regular expression object. (beside the always legal undefined value). =head3 String sub Foo : Field(String) Ensures that the field can only hold a string value. Even everything could theoretically expressed as a string, only true string values are legal. (beside the always legal undefined value). =head2 Field Types Specification Syntax Note Field types are case insensitve. If a type expects a parameter, as the C type, then it should be enclosed in parenthises. Whitespace is always ingnored, around Field types and parameters, if any. Note, however that the field type Int, spelled in lowercase letters will be misparsed as the `int` operator, so be careful. =head2 Additional Features Currently there are two categories of additional features: those going to stay, and those going to be relocated into distinct packages. First the stuff that will stay: =head3 parseArgs method Every subclass inherits this method. Its purpose is to ease the use of named parameters in constructors. It takes a list of key => value pairs. Foreach pair it calls a method named like the key with value as it only parameter (beside the object, of course), i.e: $obj->parseArgs(foo => [], bar => 'bar is better than foo'); Would result in the following method calls: $obj->foo([]); $obj->bar('bar is better than foo'); The method also strips a leading dash ('-') from the method name, in case you prefer named arguments starting with a dash, therefore the following calls are equivalent : $obj->parseArgs(-foo => 123, -bar => 456); # dashed style $obj->parseArgs(foo => 123, bar => 456); # dashless style $obj->parseArgs(-foo => 123, bar => 456); # no style Since this method needs key => value pairs it will croak if you supply it an odd number of arguments. I C returns the object. =head3 new method Every subclass inherits this method, it is merely a wrapper around the real constructor (which is called 'create'). It first constructs the object (with the help of the real constructor) and then calls parseArgs on it. This means the following code is equivalent : my $obj = class->new(-foo => 'bar'); #---- my $obj = class->create; $obj->parseArgs(-foo => 'bar'); Only shorter ;) =head3 inspect method This method is created for each subclass. It returns a hashref with the field names and their types. A short example should clarify what I try to say: package SomeClass; use base qw/Class::CompiledC/; sub foo : Field(Int); sub bar : Filed(Hashref); #### at same time in some other package: use SomeClass; use Data::Dumper; my $obj = Somelass->new; print Dumper($obj->inspect); ### prints something like $VAR1 = { 'foo' => 'Int', 'bar' => 'Hashref', } Be aware that this purely informational. Even you can change the data behind this reference, nothing will happen. The changes will not persist, if you call C again, the output will be the same. Especially do not expect that you can change a class on the fly with that hash, this won't work. You should also know that two calls to inspect will result in two distinct hash references, so don't try to compare those references. Even the hash those references refer to is diffrent, if you really want to compare than you have to do a deep compare. =head3 the C attribute The C attribute allows you to write a subroutine in C, eg: sub add : C(int, int a, int b) {q{ return a + b; }} The return type and the parameters are specified in the attribute, and the function body is in the subroutine body. Therefore the resulting C code looks like: int add(int a, int b) { return a + b; } You may have noticed that the actual body of the C function is whatever the (Perl subroutine returned, so this code : sub getCompileTime(int, ) { my $time = time; my $code = "return $time"; return $code; } will result in this C code : int getCompileTime() { return 1162140297; } The time value, is subject of change, of course. If you wonder what perl can do with c intergers, all (with a few exceptions) C code is subject to XS-fication by the L, which handles this sort of crap behind the scenes. You should have a look at L for bugs and deficiencies, but do yourself and the author of Inline a favor and not report any bugs that might showup in conjunction with Class::CompiledC to the author of Inline, report them to me. I'm cheating with Inline, and most problems you might encounter wouldn't show up by using Inline correctly. Be advised that you have full access to perls internals within your C code and to take any usage out of this feature you should read the following documents: =over =item L Perl XS tutorial =item L Perl XS application programming interface =item L Internal replacements for standard C library functions =item L Perl internal functions for those doing extensions =item L Perl calling conventions from C =back XXX The stuff that will be outsourced is not yet documented. Of course, you should also know how to code in C. One final notice: This feature has been proven as an endless source of fun and coredumps. =head2 Methods The methods listed here are not considered part of the public api, and should not be used in any way, unless you know better. Class::CompiledC defines the following methods: =cut =head3 __scheduled __scheduled SELF, PACKAGE Type: class method the __scheduled method checks if package has already been scheduled for compilation. returns a a true value if so, a false value otherwise. =cut sub __scheduled { return exists $scheduled{$_[1]} && $scheduled{$_[1]}; } =head3 __schedule __scheduled SELF, PACKAGE Type: class method the __schedule method schedules PACKAGE for compilation. Note.: try not to schedule a package for compilation more than once, you can test for a package beeing scheduled with the C<__scheduled> method, or you can use the C<__scheduleIfNeeded> which ensures that a package doesn't get scheduled multiple times. =cut sub __schedule { my $self; my $package; $self = shift || croak "no package supplied"; $package = shift || croak "no target package supplied"; $scheduled{$package} = 1; eval qq { package $package; { no warnings 'void'; CHECK { $self->__doIt('$package'); } } }; croak $@ if $@; } =head3 __scheduleIfNeeded __scheduleIfNeeded SELF, PACKAGE Type: class method the __scheduleIfNeeded method schedules PACKAGE for compilation unless it already has been scheduled. Uses C<__scheduled> to determine 'scheduledness' and C<__schedule> to do the hard work. =cut sub __scheduleIfNeeded { $_[0]->__scheduled($_[1]) || $_[0]->__schedule($_[1]); } =head3 __addCode __addCode SELF, PACKAGE, CODE, TYPE Type: class method Add code CODE for compilation of type TYPE to PACKAGE. Currently supported types are C (code for fields) and C (code for addional c functions). Before compilation C and C coe is merged, C first, so that C code can access functions and macros from the base code. =cut sub __addCode { my $code; my $type; my $package; my $self; $self = shift || croak "no package supplied"; $package = shift || croak "no target package supplied"; $code = shift || croak "no code supplied"; $type = shift || croak "no type supplied"; $type =~ /base|ext/ || croak "bad type supplied"; $code{$package} = {} unless __hashref $code{$package}; $code{$package}{$type} = '' unless $code{$package}{$type}; $code{$package}{$type} .= $code; return; } =head3 __compile __compile SELF, PACKAGE Type: class method Compiles the code for PACKAGE. =cut sub __compile { my $self; my $package; my $code; my $sub; $self = shift || croak "no package supplied"; $package = shift || croak "no target package supplied"; $code = ''; $code .= __include foreach (@{$includes{$package}}); $code .= $code{$package}{base} if $code{$package}{base}; $code .= $code{$package}{ext} if $code{$package}{ext}; #dark magic see the comment in __doIt for an explanation @_ = ('Inline', 'C', $code, 'NAME', $package, 'BUILD_NOISY', 0, 'CLEAN_AFTER_BUILD', 0, 'PREFIX' , 'CCSC_'); $sub = Inline->can('bind'); goto &$sub; } =head3 __traverseISA __traverseISA SELF, PACKAGE, HASHREF, [CODEREF] Type: class method Recursivly traverses the C<@ISA> array of PACKAGE, and returns a list of fields declared in the inheritance tree of PACKAGE. HASHREF which must be supplied (and will be modified) is used to ensure that fields will only show up once. CODEREF is a optional parameter, which, when supplied,must be a reference to the method itself and is used for recursion. If CODEREF is not supplied, __traverseISA determines it on it's own. =cut sub __traverseISA { my $self; my $package; my $found; my $f; my @funcs; $self = shift || croak "no package supplied"; $package = shift || croak "no target package supplied"; $found = shift || croak "no found hash supplied"; $f = shift || $self->can((caller(0))[3]); __hashref $found || croak "fail0r: not a hash reference"; __coderef $f || croak "fail0r: f arg supplied but not a code ref"; push @funcs, $package unless exists $found->{$package}; # XXX get rid of eval (or hide it somewhere) foreach my $pak ((eval '@'."${package}::ISA")) { unless (exists $found->{$pak}) { $found->{$pak} = 1; push @funcs, $pak; } push @funcs, $f->($self, $pak, $found, $f); } return @funcs; } =head3 __addParentFields __addParentFields SELF, PACKAGE Type: class method Adds the fields from SUPER classes to the list of fields. =cut sub __addParentFields { my $self; my $package; my $found; $self = shift || croak "no package supplied"; $package = shift || croak "no target package supplied"; $found = {}; foreach my $pkg ($self->__traverseISA($package, {})) { #print "processing package $pkg\n"; foreach my $field (@{$funcs{$pkg}}) { #print " processing func $field\n"; $found->{$field} = ($types{$pkg}{$field} || 'Any'); } } $funcs{$package} = [keys %{$found}]; $types{$package} = $found; } =head3 __doIt __doIt SELF, PACKAGE Type: class method Inherits parents fields, generates base code, generates ext code, and starts compilation for package PACKAGE. This method is meant to be called from CHECK block in the target package. The C<__schedule> or more safely the C<__scheduleIfNeeded> method can arrange that for you. =cut sub __doIt { my $self; my $package; my $sub; # dark goto &Sub magic, because the method which actually compiles the # code (Inline->bind, FYI) needs to think it is called on behalf of the # class we're engineering $self = $_[0] || croak "no package supplied"; $package = $_[1] || croak "no target package supplied"; $self->__addParentFields($package); $self->__genBaseCode($package); $self->__genExtCode($package); $sub = $self->can('__compile'); goto &$sub; } =head3 __genExtFuncCode __genExtFuncCode SELF, PACKAGE, NAME, RETVAL, ARGS, CODEREF Type: class method Generates a single ext function, NAME in package PACKAGE with return type RETVAL and parameters ARGS, with the body returned from CODEREF. Meant to be called by the C<__genExtCode> method. =cut sub __genExtFuncCode { my $self; my $package; my $name; my $retval; my $args; my $code; my $ref; $self = shift || croak "no package supplied"; $package = shift || croak "no target package supplied"; $name = shift || croak "no name supplied"; $retval = shift || croak "no retval supplied"; $args = shift || croak "no args supplied"; $ref = shift || croak "no ref supplied"; $code = $retval ; $code .= ' '; $code .= $name; $code .= $args; $code .= __circumPrint($ref->(), "\n{", "\n}\n"); $self->__addCode($package, $code, 'ext'); return; } =head3 __genExtCode __genExtCode SELF, PACKAGE Type: class method Generates all ext functions in package PACKAGE. Utilizes the C<__genExtFuncCode> method to do the dirty work. You can define ext functions with the C attribute. =cut sub __genExtCode { my $self; my $package; my $func; $self = shift || croak "no package supplied"; $package = shift || croak "no target package supplied"; foreach my $func (@{$extfuncs{$package}}) { $self->__genExtFuncCode ( $package, $func->{name}, $func->{retval}, $func->{args}, $func->{ref}, ); } return; } =head3 __genBaseCode __genBaseCode SELF, PACKAGE Type: class method Generates the C code for all fields. You can define fields with the C attribute. =cut sub __genBaseCode { my $macros; my $structdef; my $accessor; my $createSub; my $destroySub; my $funcs; my $pkg; my $structGuts; my $accessors; my $code; my $self; my $spc; my $init; my $cleanup; my $inspectSub; my $inspectGuts; my $inspectLine; $self = shift; $pkg = shift; $funcs = $funcs{$pkg}; $structGuts = ''; $accessors = ''; $spc = ' ' x 8; $inspectGuts = ''; $inspectLine = 'hv_store(hash, "%s", %d, newSVpv("%s", %d), 0);'; return unless __arrayref $funcs; return unless @{$funcs}; # XXX outsource the bodies so they are overwritable from outside ? $macros = <<' END_OF_MACROS'; #define sv2ptr(X) INT2PTR(hive, SvIV(SvRV(X))) #define dHive(X) struct hive* X #define __ISFLOAT(X) looks_like_number(X) #define __ISINT(X) SvIOK(X) #define __ISUINT(X) SvIOK_UV(X) #define __ISNUMBER(X) __ISFLOAT(X) #define __ISSTRING(X) SvPOK(X) #define __ISREF(X) SvROK(X) #define __ISARRAYREF(X) SvROK(X) && SvTYPE(SvRV(X)) == SVt_PVAV #define __ISHASHREF(X) SvROK(X) && SvTYPE(SvRV(X)) == SVt_PVHV #define __ISCODEREF(X) SvROK(X) && SvTYPE(SvRV(X)) == SVt_PVCV #define __ISOBJECT(X) sv_isobject(X) #define __ISREGEXPREF(X) sv_isa(X, "Regexp") #define __ISA(X,Y) sv_derived_from(X, Y ) #define __ANY 1 #define __WRONG_TYPE(X) croak("fail0r: bad arguments, expected "X"\n"); #define __CHECK(X, Y) if(!(X)) {__WRONG_TYPE(Y)} #define __ARG0 Inline_Stack_Item(1) END_OF_MACROS $structdef = <<' END_OF_STRUCTDEF'; struct hive { %s }; typedef struct hive* hive; END_OF_STRUCTDEF $accessor = <<' END_OF_ACCESSOR'; void CCSC_%s(SV* svp, ...) { dHive(p); Inline_Stack_Vars; p = sv2ptr(svp); if (Inline_Stack_Items == 2) { if (SvOK(__ARG0)) { %2$s /* here be check code */ } if (SvOK(p->%1$s)) { SvREFCNT_dec(p->%1$s); } if (SvROK(Inline_Stack_Item(1))) { SvREFCNT_inc(Inline_Stack_Item(1)); p->%1$s = Inline_Stack_Item(1); } else { p->%1$s = newSVsv(Inline_Stack_Item(1)); } POPs; } POPs; XPUSHs(sv_mortalcopy(p->%1$s)); XSRETURN(1); } static SV* get%1$s(SV* svp) { dHive(p); p = sv2ptr(svp); return sv_mortalcopy(p->%1$s); } #undef __ARG0 #define __ARG0 val static void set%1$s(SV* svp, SV* val) { dHive(p); p = sv2ptr(svp); if (SvOK(val)) { %2$s // here be check code } if (SvROK(p->%1$s)) { SvREFCNT_dec(p->%1$s); } p->%1$s = val; if (SvROK(val)) { SvREFCNT_inc(val); } return; } #undef __ARG0 #define __ARG0 Inline_Stack_Item(1) END_OF_ACCESSOR $createSub = <<' END_OF_CREATESUB'; SV* create(SV* self) { dHive(p); New(1, p, 1, struct hive); %s return sv_bless(newRV_noinc(newSViv(PTR2IV(p))), gv_stashsv(self, 0)); } END_OF_CREATESUB $destroySub = <<' END_OF_DESTROYSUB'; void DESTROY(SV* svp) { dHive(p); p = sv2ptr(svp); %s Safefree(p); return; } END_OF_DESTROYSUB $inspectSub = <<' END_OF_INSPECTSUB'; SV* inspect(SV* svp) { HV* hash; SV* hashref; hash = newHV(); %s hashref = newRV_noinc((SV*) hash); return hashref; } END_OF_INSPECTSUB s/\n[ ]{8}/\n/g foreach ($macros, $structdef, $accessor, $createSub, $destroySub, $inspectSub); foreach (@{$funcs}) { $structGuts .= $spc."SV* $_;\n"; $accessors .= sprintf($accessor, $_, $types{$pkg}{$_} ? __parseFieldType $types{$pkg}{$_} : '//'); $init .= __circumPrint($_, $spc."p->",' = &PL_sv_undef;'); $init .= "\n"; $cleanup .= $spc."if (SvOK(p->$_))\n"; $cleanup .= __circumPrint(($spc x 2)."SvREFCNT_dec(p->$_);\n", $spc."{\n", $spc."}\n"); $inspectGuts .= $spc; $inspectGuts .= sprintf $inspectLine, $_, length $_, $types{$pkg}{$_}, length $types{$pkg}{$_}; $inspectGuts .= "\n"; } $code = join("\n", $macros, sprintf($structdef, $structGuts), sprintf($createSub, $init), sprintf($destroySub, $cleanup), sprintf($inspectSub, $inspectGuts), $accessors); $self->__addCode($pkg, $code, 'base'); return; } =head3 parseArgs parseArgs SELF, LOTS_OF_STUFF Type: object method Used for named parameters in constructors. Returns the object, for simplified use in constructors. =cut sub parseArgs { my $self; my $method; my $opt; $self = shift; @_ % 2 && croak "odd number of arguments"; while (@_) { $method = shift; $opt = shift; $method =~ s/^-?//g; $self->$method($opt); } return $self; } =head3 new new SELF, PACKAGE, LOTS_OF_STUFF Type: class method Highlevel Constructor, first calls the C constructor to allocate the C structure, and then calls parseArgs to initialize the object. =cut sub new { return shift->create->parseArgs(@_); } =head2 Subroutines The subroutines listed here are not considered part of the public api, and should not be used in any way, unless you know better. Class::CompiledC defines the following subroutines =head3 __circumPrint __circumPrint TEXT, LEFT, RIGHT Type: Subroutine. Export: on request. Prototype: $$$ Utitlity function, concatenates it's arguments, in the order C<$_[1].$_[0].$_[1]> and returns the resulting string. Does not print anything. =cut sub __circumPrint($$$) { return $_[1].$_[0].$_[2]; } =head3 __include __include I Type: Subroutine. Export: on request. Prototype: none Takes C<$_> and returns a string in form C<\n#include $_\n>. This subroutine is used to generate C include directives, from the C attribute. Note that it doesn't add C<<>> or C<""> around the include, you have to do this your self. =cut sub __include { return __circumPrint($_ , "\n#include ", "\n"); } =head3 __baseref __baseref REFERENCE, TYPE Type: Subroutine. Export: on request. Prototype: $$ Determines if REFERENCE is actually a reference and and is of type TYPE. =cut sub __baseref($$) { defined $_[0] && ref $_[0] && ref $_[0] eq $_[1]; } =head3 __hashref __hashref REFERENCE Type: Subroutine. Export: on request. Prototype: $ Determines if REFERENCE is actually a hash reference. Utitlizes C<__baseref>. =cut sub __hashref($) { __baseref $_[0], 'HASH'; } =head3 __arrayref __arrayref REFERENCE Type: Subroutine. Export: on request. Prototype: $ Determines if REFERENCE is actually a array reference. Utitlizes C<__baseref>. =cut sub __arrayref($) { __baseref $_[0], 'ARRAY'; } =head3 __coderef __coderef REFERENCE Type: Subroutine. Export: on request. Prototype: $ Determines if REFERENCE is actually a code reference. Utitlizes C<__baseref>. =cut sub __coderef($) { __baseref($_[0], 'CODE') } =head3 __fetchSymbolName __fetchSymbolName GLOBREF Type: Subroutine. Export: on request. Prototype: $ Returns the Symbol name from the glob reference GLOBREF. Croaks if GLOBREF acutally isn't a glob reference. =cut sub __fetchSymbolName($) { no strict 'refs'; my $symbol = shift; __baseref $symbol, 'GLOB' or croak 'not a GLOB reference'; return *$symbol{NAME}; } =head3 __promoteFieldTypeToMacro __promoteFieldTypeToMacro FIELDTYPE Type: Subroutine. Export: on request. Prototype: none Takes a fieldtype specfication, and returns a C macro for doing the test. Does not handle parametric types like C. See C<__parseFieldType> for that. =cut sub __promoteFieldTypeToMacro($) { my $type = shift; return '' unless ($type); return '' if ($type =~ /^any$/i); return sprintf '__CHECK(__IS%s(__ARG0), "%s")', uc $type, $type; } =head3 __parseFieldType __parseFieldType FIELDTYPE Type: Subroutine. Export: on request. Prototype: none Takes a fieldtype specfication, and returns a C macro for doing the test. Handles all field types. Delegates most work to the C<__promoteFieldTypeToMacro> subroutine. =cut sub __parseFieldType { local $_ = shift; if (/$re_ft/) { # warn sprintf "yeah %s !", __promoteFieldTypeToMacro $1; return __promoteFieldTypeToMacro($1); } elsif (/$re_ft_isa/) { croak "fail0r: isa type needs a classname argument\n" unless $1; return '__CHECK(__ISA(__ARG0, '."\"$1\"), \"__ISA\")"; } else { croak "fail0r: bad type specified $_\n"; } } =head3 Include sub Foo : C(...) Include() sub Foo : Field(...) Include("bar.h") Type: Attribute Handler Export: no. =cut sub Include : ATTR(CODE, BEGIN) { my $package; my $symbol; my $ref; my $attribute; my $data; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift || croak "no includes supplied"; $data = [ $data ] unless __arrayref $includes{$package}; $includes{$package} = [] unless __arrayref $data; push @{$includes{$package}}, @{$data}; } =head3 C sub Foo : C(RETVAL, ARG0, ...) Type: Attribute Handler Export: no. =cut sub C : ATTR(CODE, CHECK, RAWDATA) { my $package; my $symbol; my $attribute; my $data; my $ref; my $retval; my $name; my $self; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift || croak "no return type and parameters specified"; $extfuncs{$package} = [] unless __arrayref $extfuncs{$package}; $data =~ s/(?:\s*)([a-zA-Z_]+[a-zA-Z0-9_]*(?:\*)*)(?:\s*),//; $retval = $1; push @{$extfuncs{$package}}, { name => __fetchSymbolName($symbol), args => __circumPrint($data, '(', ')'), retval => $retval, ref => $ref, }; $self = __PACKAGE__; $self->__scheduleIfNeeded($package); return; } =head3 Field sub Foo : Field(TYPE) Type: Attribute Handler Export: no. =cut sub Field : ATTR(CODE, CHECK) { my $package; my $symbol; my $ref; my $attribute; my $data; my $self; my $name; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift; $self = __PACKAGE__; $name = __fetchSymbolName($symbol); $funcs{$package} = [] unless __arrayref $funcs{$package}; push @{$funcs{$package}}, $name; $types{$package}{$name} = $data if $data; $self->__scheduleIfNeeded($package); return; } =head3 Alias sub Foo : Alias(\&REALMETHOD) Type: Attribute Handler Export: no. =cut sub Alias : ATTR(CODE) { my $package; my $symbol; my $attribute; my $data; my $ref; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift || croak "no alias supplied"; __coderef $data or croak "parameter for Alias must be coderef"; *$symbol = $data; return; } =head3 Overload sub Foo : Overload(OPERATOR) Type: Attribute Handler Export: no. =cut sub Overload : ATTR(CODE) { my $package; my $symbol; my $attribute; my $data; my $ref; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift || croak "no operator to Overload supplied"; $package->overload::OVERLOAD($data, $ref); return; } =head3 Const sub Foo : Const(VALUE) Type: Attribute Handler Export: no. =cut sub Const : ATTR(CODE, CHECK) { no warnings 'prototype'; my $package; my $symbol; my $attribute; my $data; my $ref; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift || croak "no value supplied "; *$symbol = sub () {$data}; return; } =head3 Abstract sub Foo : Abstract Type: Attribute Handler Export: no. =cut sub Abstract : ATTR(CODE, CHECK) { my $package; my $symbol; my $attribute; my $data; my $ref; my $name; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift && croak "Abstract doesn't take parameters"; $name = __fetchSymbolName $symbol; *$symbol = sub { Carp::croak("Abstract method '", $name, "' in package '", $package, "' not implemented"); }; return; } =head3 Class sub Foo : Class(CLASS) Type: Attribute Handler Export: no. =cut sub Class : ATTR(CODE, CHECK) { my $package; my $symbol; my $attribute; my $data; my $ref; my $name; $package = shift || croak "no package supplied"; $symbol = shift || croak "no symbol supplied"; $ref = shift || croak "no reference supplied"; $attribute = shift || croak "no attribute supplied"; $data = shift; $name = __fetchSymbolName $symbol; $data ? eval "use $data" : eval "use ${package}::Method::${name}"; bless *{$symbol}{CODE}, ($data || "${package}::Method::${name}"); return; } =head2 Inheritance Class::CompiledC inherits the following methods from it's ancestors =over =item methods inherited from C =over =item C =item C<_resolve_lastattr> =item C =item C<_gen_handler_AH_> =item C<_apply_handler_AH_> =back =back =head2 Export Class::CompiledC does not export anything by default but has a number of subroutines to Export on request. =head2 Export Tags Class::CompiledC defines the following export tags: =over =item ref Subroutines to verify the type of references =item misc miscellanous subroutines =item field specification subroutines =item intern miscellanous subroutines with low value outside this package =item all Everything. =back =cut BEGIN { $EXPORT_TAGS{ref} = [qw/__arrayref __coderef __hashref/]; $EXPORT_TAGS{misc} = [qw/__fetchSymbolName __baseref __circumPrint/]; $EXPORT_TAGS{field} = [qw/__parseFieldType __promoteFieldTypeToMacro/]; $EXPORT_TAGS{intern} = [qw/__include/]; $EXPORT_TAGS{all} = [map {@{$_}} values %EXPORT_TAGS ]; } =head2 Exportable Symbols The following subroutines are (im|ex)portable, either explicitly by name or as part of a tag. =over =item C<__include> =item C<__arrayref> =item C<__coderef> =item C<__hashref> =item C<__fetchSymbolName> =item C<__baseref> =item C<__circumPrint> =item C<__parseFieldType> =item C<__promoteFieldTypeToMacro> =back =cut BEGIN { @EXPORT_OK = @{$EXPORT_TAGS{all}}; } =head1 EXAMPLES You also should take a look at the .t files, The Code is a bit weird but may grant you a few insights. =head2 The Point Example. package Point; use strict; use warnings; use base qw/Class::CompiledC/; sub x : Field(Number); sub y : Field(Number); 1; #### in main use strict; #always use strict. use warnings; use Point; my $p = Point->new(x => 0.1, y => 5.0); =head2 The Web Page Example package WWW::Web::Page; use strict; use warnings; use base qw/Class::CompiledC/; sub title : Field(String); sub url : Field(String); sub content : Field(String); sub rating : Field(Int); sub comment : Field(String); #### in main use strict; #always use strict. use warnings; use WWW::Web::Page; my $page = WWW::Web::Page->new(url => 'http://dropfknuck.net'); $page->title('dropfknuck.net Geek Search Engine'); $page->content($OtherPackages::LOTS_OF_STUFF); $page->rating($your_mile_age_will_vary); $page->comment('Home of the dropfbot, also based on Class::CompiledC'); foreach my $m (qw/title url content rating comment/) { print $page->$m(); } #ok this example is just an advertisement. I apologise for stealing your time. =head1 DIAGNOSTICS =over =item C this message is usually caused by an class method called as a subroutine. I =item C Some methods (and subroutines, btw) need a target package to operate on, it seems that the argument is missing, or has evaluated to false value, which very unlikely to be valid. I =item C This message is is caused by the __addCode method, which renders useless without a supplied code argument. I =item C This message is caused by the __addCode method, when called without a type argument. The __addCode method can only operate with a valid type argument. Currently valid types are C and C but more may be added in future. I =item C This message is caused by the __addCode method, when called with a invalid type argument. Currently valid types are C and C but more may be added in future. I =item C This message is caused by the __parseFieldType subroutine. The __parseFieldType subroutine (which gets called by the Field attribute handler) found C as type but without a classname. A is a check doesn't make sense without a classname. If you just want to make sure that it is a object, you may use C or (generally faster and shorter) C. I =item C This message is caused by the __traverseISA method, which needs a hashreference as third argument, for speed considerartions. I =item C This message is caused by the __traverseISA method, which accepts a reference to itself, both for efficiency reasons and security from renamings. I =item C This message is caused by the __traverseISA method, when called without the third argument. (Which must be a hashreference, I will be changed by the method) I =item C This message can be issued from different sources, but most often by attribute handlers, which misses a reference to a typeglob. Don't call attribute handlers on your own. (unless you really know what you do) I =item C This message can be issued from different sources, but most often by attribute handlers, which misses a reference to whatever they decorate. Don't call a ttribute handlers on your own. (unless you really know what you do) I =item C This message can be issued from different sources, but most often by attribute handlers, which misses the attribute they should handler. Don't call a ttribute handlers on your own. (unless you really know what you do) I =item C This message is caused by the C attribute handler. The C handlers just couldn't figure out what to do. Give him a hand and specify what should be included. I =item C This message is specific to the C attribute handler subroutine. To compile the code it needs to know the return type and the parameter list of the C function to be compiled. I =item C This message is caused by the __genExtFuncCode method when called without a fieldname. I =item C This message is caused by the __genExtFuncCode method when called without a return type argument. I =item C This message is caused by the __genExtFuncCode method when called without a args argument. I =back =head1 BUGS There are undoubtedly serious bugs lurking somewhere. =over =item there is a (undocumented) UINT type specifier for unsigned ints, but it doesn't work right, actually it doesn't work at all, don't try to use it. =back =head1 TODO =over =item *serious code cleanup I still find too much things that are done the fast way instead of the right way, this really bothers me. =item *outsourcing A few things need to be outsourced right away. I just don't know where to put them. Especially the stuff not related to classes should be placed somewhere else. The utility __.* subs (not methods!) could be placed in a different package and locally (or maybe lexically?) imported, to avoid namespace pollution of subclasses. Random thought: lexical importing ? what a cute idea! is this possible? =back =head1 SEE ALSO =over =item L Class::CompiledC utilizes Inline::C to do the dirty work. =item L Geek Search Engine. Utilizes Class::CompiledC under a CGI Environment. =back =head1 AUTHOR Lionel Mehl blackhat.blade The Hive dropfknuck.net Geek Search Engine blade@dropfknuck.net =head1 COPYRIGHT Copyright (c) 2005, 2006, 2007 blackhat.blade The Hive. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the terms of the Artistic license. =cut 1; __END__ 2.14 Wed Jan 18 00:44:39 CET 2006 @31 /Internet Time/ everything till here... 2.15 Thu Jan 19 20:28:41 CET 2006 @853 /Internet Time/ fixed documentation issues, the Field type for regular exprssions is C and I C. I also had Regexenref in mind... 2.16 Sun Oct 08 00:05:19 CEST 2006 @962 /Internet Time/ fixed (?:Array|Code|Hash)ref type checking code 2.17 Sat Oct 21 01:01:45 CEST 2006 @1 /Internet Time/ added a few sanity checks for __fetchSymbolName 2.18 Sun Oct 22 13:21:16 CEST 2006 @514 /Internet Time/ fixed some serious bugs concerning refcounts of non ref values fixed (?:Array|Code|Hash)ref type checking code 2.19 Sun Oct 22 19:52:04 CEST 2006 @786 /Internet Time/ relocated field type parsing into __genBaseCode in anticipation to support introspection refactored __promoteFieldTypeToMacro sub adapted __addParentFields to emit only valid field types added inspect method, it returns a hashref with fieldnames as keys and field types as values. (you may change that hash but don't expect any changes to persist, or even to propagate back and change the class on the fly, we are not at this point, and we're not going into this directon) 2.20 Thu Oct 26 21:48:22 CEST 2006 @866 /Internet Time/ first public release renamed to Class::CompiledC to avoid the creation of a new root namespace added version requirement for 5.8.7, sorry for this but I cannot tell if it will run with earlier versions. 2.21 Fri Oct 27 23:27:38 CEST 2006 @935 /Internet Time/ no code changes, fixed errors in Makefile.pl 2.22 Sun Oct 29 22:52:42 CET 2006 @953 /Internet Time/ updated documentation, minor code cleanups. 2.23 Fri Aug 03 16:08:26 CEST 2007 @630 /Internet Time/ added a prefix to variable named c functions to avoid nameclashes with perls internal and the c standard lib. documentation updates. Class-CompiledC2.23/Class-CompiledC/Makefile.PL0000744000076500007650000000061510654641775021335 0ustar bladeblade00000000000000use 5.008007; use ExtUtils::MakeMaker; WriteMakefile ( NAME => 'Class::CompiledC', VERSION_FROM => 'lib/Class/CompiledC.pm', PREREQ_PM => { Inline => 0.44, }, ABSTRACT_FROM => 'lib/Class/CompiledC.pm', AUTHOR => 'blackhat.blade ', ); Class-CompiledC2.23/Class-CompiledC/MANIFEST0000744000076500007650000000012510520174204020464 0ustar bladeblade00000000000000Changes Makefile.PL MANIFEST README t/Class-CompiledC.t lib/Class/CompiledC.pm Class-CompiledC2.23/Class-CompiledC/README0000744000076500007650000000412110654641703020226 0ustar bladeblade00000000000000Class-CompiledC version 2.23 ============================ Class::CompiledC let's you implement your Objects as C structs, with type checking accessor methods. Version 2.20 was the first public release of this module, and you better treat the version number as $VERSION -= 2.19. I have been using this code for long time, it's has proven to be stable (for me, on a limited number of platforms, so it is very likely that you will encounter things i never saw) The code behind this module has constantly changed, it started as a class with just an AUTOLOAD routine to provide autogenerated accessor methods for hashbased objects, but that's along time and a half a million lines of deleted code ago. Class::CompiledC has been tested with perls from 5.6 but was only recently tested on 5.8.7 and 5.9.4, both on Windows (2003, Enterprise Server FYI). I used it successfully with Microft Visual C++ 7.0 (and it's NMAKE) MinGW (Version 3.2.0) (with a fairly old MS NMAKE) MinGW (Verison 3.4.5) (with dmake 4.5) gcc version 4.1.2 20061115 (prerelease) (Debian 4.1.1-21) I also run my site (dropfknuck.net Geek Search Engine) with it, running in cgi mode under apache3 works fine. If you have any suggestions, bug reports, improvements, patches or comments then drop me a mail at blade@dropfknuck.net . If you however want to sell me Viagra, Penis Enlargements or want to make me Business proposals, then i encourage you to use only uppercase letters to improve readablity for me. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Inline Inline::C a working C Compiler !!! COPYRIGHT AND LICENCE Copyright (c) 2005, 2006, 2007 Lionel Mehl blackhat.blade The Hive dropfknuck.net Geek Search Engine blade@dropfknuck.net This module is free software. It may be used, redistributed and/or modified under the terms of the Artistic license. Class-CompiledC2.23/Class-CompiledC/t/0000755000076500007650000000000010654642147017615 5ustar bladeblade00000000000000Class-CompiledC2.23/Class-CompiledC/t/Class-CompiledC.t0000744000076500007650000006623710521204772022712 0ustar bladeblade00000000000000# test-script for Class::CompiledC (aka Hive::Ex aka Hive::Core) # all tests should pass without any exception # if any test fails, something is really broken # this test-script is far from complete, additions welcome ;) use Test::More tests => 234; use Scalar::Util qw'dualvar'; use strict; use warnings; no warnings qw'prototype'; use_ok('Class::CompiledC'); { local $_ = 'foobar'; is (Class::CompiledC::__include(), "\n#include foobar\n", 'test __include'); } sub dies_with(&$$) { my $sub = shift; my $die = shift; my $text = shift; my $tmp; my $res = eval {&$sub}; $tmp = $@; warn "is $tmp\nresult is $res\n" unless $tmp =~ $die; ok ($tmp =~ $die, $text); } sub no_die(&$) { my $sub = shift; my $text = shift; local $@; eval {&$sub}; pass($text) unless $@; fail($text." \n expected no die but got '$@'") if $@; } ok( Class::CompiledC::__baseref({}, 'HASH'), 'baseref hash positive'); ok(!Class::CompiledC::__baseref('foo', 'HASH'), 'baseref hash negative (string)'); ok(!Class::CompiledC::__baseref([], 'HASH'), ' baseref hash negative (arrayref)'); ok(!Class::CompiledC::__baseref(12, 'HASH'), 'baseref hash negative (number)'); ok(!Class::CompiledC::__baseref(sub {}, 'HASH'), 'baseref hash negative (coderef)'); ok(!Class::CompiledC::__baseref(undef, 'HASH'), 'baseref hash negative (undef)'); ok(!Class::CompiledC::__baseref(\*foo, 'HASH'), 'baseref hash negative (globref)'); ok(!Class::CompiledC::__baseref(\1, 'HASH'), 'baseref hash negative (scalarref)'); ok( Class::CompiledC::__baseref([], 'ARRAY'), 'baseref array positive'); ok(!Class::CompiledC::__baseref('foo', 'ARRAY'), 'baseref array negative (string)'); ok(!Class::CompiledC::__baseref({}, 'ARRAY'), 'baseref array negative (hashref)'); ok(!Class::CompiledC::__baseref(12, 'ARRAY'), 'baseref array negative (number)'); ok(!Class::CompiledC::__baseref(sub {}, 'ARRAY'), 'baseref array negative (coderef)'); ok(!Class::CompiledC::__baseref(undef, 'ARRAY'), 'baseref array negative (undef)'); ok(!Class::CompiledC::__baseref(\*foo, 'ARRAY'), 'baseref array negative (globref)'); ok(!Class::CompiledC::__baseref(\1, 'ARRAY'), 'baseref array negative (scalarref)'); ok( Class::CompiledC::__baseref(\1, 'SCALAR'), 'baseref array positive'); ok(!Class::CompiledC::__baseref('foo', 'SCALAR'), 'baseref array negative (string)'); ok(!Class::CompiledC::__baseref({}, 'SCALAR'), 'baseref array negative (hashref)'); ok(!Class::CompiledC::__baseref(12, 'SCALAR'), 'baseref array negative (number)'); ok(!Class::CompiledC::__baseref(sub {}, 'SCALAR'), 'baseref array negative (coderef)'); ok(!Class::CompiledC::__baseref(undef, 'SCALAR'), 'baseref array negative (undef)'); ok(!Class::CompiledC::__baseref(\*foo, 'SCALAR'), 'baseref array negative (globref)'); ok(!Class::CompiledC::__baseref([], 'SCALAR'), 'baseref array negative (arrayref)'); ok( Class::CompiledC::__baseref(sub {}, 'CODE'), 'baseref code positive'); ok(!Class::CompiledC::__baseref('foo', 'CODE'), 'baseref code negative (string)'); ok(!Class::CompiledC::__baseref({}, 'CODE'), 'baseref code negative (hashref)'); ok(!Class::CompiledC::__baseref(12, 'CODE'), 'baseref code negative (number)'); ok(!Class::CompiledC::__baseref(\*foo, 'CODE'), 'baseref code negative (globref)'); ok(!Class::CompiledC::__baseref(undef, 'CODE'), 'baseref code negative (undef)'); ok(!Class::CompiledC::__baseref(\1, 'CODE'), 'baseref code negative (scalarref)'); ok(!Class::CompiledC::__baseref([], 'CODE'), 'baseref code negative (arrayref)'); ok( Class::CompiledC::__baseref(\*foo, 'GLOB'), 'baseref glob positive'); ok(!Class::CompiledC::__baseref('foo', 'GLOB'), 'baseref glob negative (string)'); ok(!Class::CompiledC::__baseref({}, 'GLOB'), 'baseref glob negative (hashref)'); ok(!Class::CompiledC::__baseref(12, 'GLOB'), 'baseref glob negative (number)'); ok(!Class::CompiledC::__baseref(sub {}, 'GLOB'), 'baseref glob negative (coderef)'); ok(!Class::CompiledC::__baseref(undef, 'GLOB'), 'baseref glob negative (undef)'); ok(!Class::CompiledC::__baseref(\1, 'GLOB'), 'baseref glob negative (scalarref)'); ok(!Class::CompiledC::__baseref([], 'GLOB'), 'baseref glob negative (arrayref)'); ok( Class::CompiledC::__arrayref([]), '__arrayref positive'); ok(!Class::CompiledC::__arrayref('foo'), '__arrayref negative (string)'); ok(!Class::CompiledC::__arrayref({}), '__arrayref negative (hashref)'); ok(!Class::CompiledC::__arrayref(12), '__arrayref negative (number)'); ok(!Class::CompiledC::__arrayref(sub {}), '__arrayref negative (coderef)'); ok(!Class::CompiledC::__arrayref(undef), '__arrayref negative (undef)'); ok(!Class::CompiledC::__arrayref(\*foo), '__arrayref negative (globref)'); ok(!Class::CompiledC::__arrayref(\1), '__arrayref negative (scalarref)'); ok( Class::CompiledC::__hashref({}), '__hashref positive'); ok(!Class::CompiledC::__hashref('foo'), '__hashref negative (string)'); ok(!Class::CompiledC::__hashref([]), '__hashref negative (arrayref)'); ok(!Class::CompiledC::__hashref(12), '__hashref negative (number)'); ok(!Class::CompiledC::__hashref(sub {}), '__hashref negative (coderef)'); ok(!Class::CompiledC::__hashref(undef), '__hashref negative (undef)'); ok(!Class::CompiledC::__hashref(\*foo), '__hashref negative (globref)'); ok(!Class::CompiledC::__hashref(\1), '__hashref negative (scalarref)'); ok( Class::CompiledC::__coderef(sub {}), '__coderef positive'); ok(!Class::CompiledC::__coderef('foo'), '__coderef negative (string)'); ok(!Class::CompiledC::__coderef([]), '__coderef negative (arrayref)'); ok(!Class::CompiledC::__coderef(12), '__coderef negative (number)'); ok(!Class::CompiledC::__coderef({}), '__coderef negative (hashref)'); ok(!Class::CompiledC::__coderef(undef), '__coderef negative (undef)'); ok(!Class::CompiledC::__coderef(\*foo), '__coderef negative (globref)'); ok(!Class::CompiledC::__coderef(\1), '__coderef negative (scalarref)'); is(Class::CompiledC::__circumPrint('b', 'a', 'c'), 'abc', 'test __circumPrint simple'); is(Class::CompiledC::__circumPrint('b', 'a', 'c', 'd'), 'abc', 'test __circumPrint extra parameter'); is(Class::CompiledC::__circumPrint(2, 1, 3), '123', 'test __circumPrint numeric parameters'); is(Class::CompiledC::__circumPrint(dualvar (1, 'b'), 'a', 'c'), 'abc', 'test __circumPrint daulvar\'ed parameter'); is(Class::CompiledC::__circumPrint('b' x 500, 'a' x 500, 'c' x 500), ('a' x 500).('b' x 500).('c' x 500), 'test __circumPrint large parameters'); is(Class::CompiledC::__fetchSymbolName(\*FOO), 'FOO', '__fetchSymbolName positive'); dies_with { Class::CompiledC::__fetchSymbolName(\&FOO), } qr/not a glob reference/i, '__fetchSymbolName negative (coderef)'; dies_with { Class::CompiledC::__fetchSymbolName(1), } qr/not a glob reference/i, '__fetchSymbolName negative (number)'; dies_with { Class::CompiledC::__fetchSymbolName('foobar'), } qr/not a glob reference/i, '__fetchSymbolName negative (string)'; dies_with { Class::CompiledC::__fetchSymbolName([]), } qr/not a glob reference/i, '__fetchSymbolName negative (arrayref)'; dies_with { Class::CompiledC::__fetchSymbolName({}), } qr/not a glob reference/i, '__fetchSymbolName negative (hashref)'; dies_with { Class::CompiledC::__fetchSymbolName(\$$), } qr/not a glob reference/i, '__fetchSymbolName negative (scalarref)'; dies_with { Class::CompiledC::__fetchSymbolName(qr/foo/), } qr/not a glob reference/i, '__fetchSymbolName negative (regexref)'; dies_with { Class::CompiledC::__fetchSymbolName(bless [], 'foobar'), } qr/not a glob reference/i, '__fetchSymbolName negative (blessed reference)'; is (Class::CompiledC::__promoteFieldTypeToMacro('FOO'), '__CHECK(__ISFOO(__ARG0), "FOO")', '__promoteFieldTypeToMacro simple test'); is (Class::CompiledC::__promoteFieldTypeToMacro('fOoBaR'), '__CHECK(__ISFOOBAR(__ARG0), "fOoBaR")', '__promoteFieldTypeToMacro case test'); is (Class::CompiledC::__promoteFieldTypeToMacro('any'), '', '__promoteFieldTypeToMacro any test'); is (Class::CompiledC::__parseFieldType('Isa(FOO)'), '__CHECK(__ISA(__ARG0, "FOO"), "__ISA")', '__parseFieldType isa test'); is (Class::CompiledC::__parseFieldType('int'), '__CHECK(__ISINT(__ARG0), "int")', '__parseFieldType int test'); is (Class::CompiledC::__parseFieldType('float'), '__CHECK(__ISFLOAT(__ARG0), "float")', '__parseFieldType float test'); is (Class::CompiledC::__parseFieldType('number'), '__CHECK(__ISNUMBER(__ARG0), "number")', '__parseFieldType number test'); is (Class::CompiledC::__parseFieldType('string'), '__CHECK(__ISSTRING(__ARG0), "string")', '__parseFieldType string test'); is (Class::CompiledC::__parseFieldType('ref'), '__CHECK(__ISREF(__ARG0), "ref")', '__parseFieldType ref test'); is (Class::CompiledC::__parseFieldType('arrayref'), '__CHECK(__ISARRAYREF(__ARG0), "arrayref")', '__parseFieldType arrayref test'); is (Class::CompiledC::__parseFieldType('hashref'), '__CHECK(__ISHASHREF(__ARG0), "hashref")', '__parseFieldType hashref test'); is (Class::CompiledC::__parseFieldType('coderef'), '__CHECK(__ISCODEREF(__ARG0), "coderef")', '__parseFieldType coderef test'); is (Class::CompiledC::__parseFieldType('object'), '__CHECK(__ISOBJECT(__ARG0), "object")', '__parseFieldType object test'); is (Class::CompiledC::__parseFieldType('regexpref'), '__CHECK(__ISREGEXPREF(__ARG0), "regexpref")', '__parseFieldType regexpref test'); is (Class::CompiledC::__parseFieldType('any'), '', '__parseFieldType any test'); is (Class::CompiledC::__parseFieldType('uint'), '__CHECK(__ISUINT(__ARG0), "uint")', '__parseFieldType uint test'); dies_with { Class::CompiledC::__parseFieldType('bad field type') } qr/fail0r: bad type specified/i, '__parseFieldType unknown field test'; BEGIN { my $test_class1 = <<'HERE'; package Class::CompiledCTest; use base qw/Class::CompiledC/; sub int_field : Field(Int); sub float_field : Field(Float); sub number_field : Field(Number); sub string_field : Field(String); sub ref_field : Field(Ref); sub arrayref_field : Field(Arrayref); sub hashref_field : Field(Hashref); sub coderef_field : Field(Coderef); sub object_field : Field(Object); sub regexpref_field : Field(Regexpref); sub any_field : Field(Any); HERE eval $test_class1; } my $obj = Class::CompiledCTest->new(); no_die { $obj->int_field(1) } 'int_field positive'; dies_with { $obj->int_field([]) } qr/fail0r: bad arguments, expected/, 'int_field negative (arrayref)'; dies_with { $obj->int_field({}) } qr/fail0r: bad arguments, expected/, 'int_field negative (hashref)'; dies_with { $obj->int_field(sub {}) } qr/fail0r: bad arguments, expected/, 'int_field negative (coderef)'; dies_with { $obj->int_field(\*foo) } qr/fail0r: bad arguments, expected/, 'int_field negative (globref)'; dies_with { $obj->int_field(qr/foo?/) } qr/fail0r: bad arguments, expected/, 'int_field negative (regexp ref)'; dies_with { $obj->int_field(bless([], 'foo')) } qr/fail0r: bad arguments, expected/, 'int_field negative (object)'; dies_with { $obj->int_field(\[]) } qr/fail0r: bad arguments, expected/, 'int_field negative (scalarref)'; dies_with { $obj->int_field('foobar') } qr/fail0r: bad arguments, expected/, 'int_field negative (string)'; dies_with { $obj->int_field('123') } qr/fail0r: bad arguments, expected/, 'int_field negative (string int)'; dies_with { $obj->int_field(123.3) } qr/fail0r: bad arguments, expected/, 'int_field negative (float)'; no_die { $obj->float_field(1) } 'float_field positive (bare 1)'; no_die { $obj->float_field('123') } 'float_field negative (string int)'; no_die { $obj->float_field(123.3) } 'float_field negative (float)'; dies_with { $obj->float_field([]) } qr/fail0r: bad arguments, expected/, 'float_field negative (arrayref)'; dies_with { $obj->float_field({}) } qr/fail0r: bad arguments, expected/, 'float_field negative (hashref)'; dies_with { $obj->float_field(sub {}) } qr/fail0r: bad arguments, expected/, 'float_field negative (coderef)'; dies_with { $obj->float_field(\*foo) } qr/fail0r: bad arguments, expected/, 'float_field negative (globref)'; dies_with { $obj->float_field(qr/foo?/) } qr/fail0r: bad arguments, expected/, 'float_field negative (regexp ref)'; dies_with { $obj->float_field(bless([], 'foo')) } qr/fail0r: bad arguments, expected/, 'float_field negative (object)'; dies_with { $obj->float_field(\[]) } qr/fail0r: bad arguments, expected/, 'float_field negative (scalarref)'; dies_with { $obj->float_field('foobar') } qr/fail0r: bad arguments, expected/, 'float_field negative (string)'; no_die { $obj->number_field(1) } 'number_field positive (bare 1)'; no_die { $obj->number_field('123') } 'number_field negative (string int)'; no_die { $obj->number_field(123.3) } 'number_field negative (number)'; dies_with { $obj->number_field([]) } qr/fail0r: bad arguments, expected/, 'number_field negative (arrayref)'; dies_with { $obj->number_field({}) } qr/fail0r: bad arguments, expected/, 'number_field negative (hashref)'; dies_with { $obj->number_field(sub {}) } qr/fail0r: bad arguments, expected/, 'number_field negative (coderef)'; dies_with { $obj->number_field(\*foo) } qr/fail0r: bad arguments, expected/, 'number_field negative (globref)'; dies_with { $obj->number_field(qr/foo?/) } qr/fail0r: bad arguments, expected/, 'number_field negative (regexp ref)'; dies_with { $obj->number_field(bless([], 'foo')) } qr/fail0r: bad arguments, expected/, 'number_field negative (object)'; dies_with { $obj->number_field(\[]) } qr/fail0r: bad arguments, expected/, 'number_field negative (scalarref)'; dies_with { $obj->number_field('foobar') } qr/fail0r: bad arguments, expected/, 'number_field negative (string)'; no_die { $obj->string_field('foobar') } 'string_field positive (string)'; no_die { $obj->string_field('123') } 'string_field positive (int string)'; dies_with { $obj->string_field([]) } qr/fail0r: bad arguments, expected/, 'string_field negative (arrayref)'; dies_with { $obj->string_field({}) } qr/fail0r: bad arguments, expected/, 'string_field negative (hashref)'; dies_with { $obj->string_field(sub {}) } qr/fail0r: bad arguments, expected/, 'string_field negative (coderef)'; dies_with { $obj->string_field(\*foo) } qr/fail0r: bad arguments, expected/, 'string_field negative (globref)'; dies_with { $obj->string_field(qr/foo?/) } qr/fail0r: bad arguments, expected/, 'string_field negative (regexp ref)'; dies_with { $obj->string_field(bless([], 'foo')) } qr/fail0r: bad arguments, expected/, 'string_field negative (object)'; dies_with { $obj->string_field(\[]) } qr/fail0r: bad arguments, expected/, 'string_field negative (scalarref)'; dies_with { $obj->string_field(1) } qr/fail0r: bad arguments, expected/, 'string_field negative (bare number)'; dies_with { $obj->string_field(123.3) } qr/fail0r: bad arguments, expected/, 'string_field negative (float)'; no_die { $obj->ref_field([]) } 'ref_field positive (arrayref)'; no_die { $obj->ref_field({}) } 'ref_field positive (hashref)'; no_die { $obj->ref_field(sub {}) } 'ref_field positive (coderef)'; no_die { $obj->ref_field(\*foo) } 'ref_field positive (globref)'; no_die { $obj->ref_field(qr/foo?/) } 'ref_field positive (regexp ref)'; no_die { $obj->ref_field(bless([], 'foo')) } 'ref_field positive (object)'; no_die { $obj->ref_field(\[]) } 'ref_field positive (scalarref)'; dies_with { $obj->ref_field(1) } qr/fail0r: bad arguments, expected/, 'ref_field negative (bare number)'; dies_with { $obj->ref_field('foobar') } qr/fail0r: bad arguments, expected/, 'ref_field negative (string)'; dies_with { $obj->ref_field('123') } qr/fail0r: bad arguments, expected/, 'ref_field negative (string ref)'; dies_with { $obj->ref_field(123.3) } qr/fail0r: bad arguments, expected/, 'ref_field negative (float)'; dies_with { $obj->arrayref_field(1) } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (bare number)'; no_die { $obj->arrayref_field([]) } 'arrayref_field positive (arrayref)'; no_die { $obj->arrayref_field(bless([], 'foo')) } 'arrayref_field positive (object from arrayref)'; dies_with { $obj->arrayref_field({}) } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (hashref)'; dies_with { $obj->arrayref_field(sub {}) } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (coderef)'; dies_with { $obj->arrayref_field(\*foo) } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (globref)'; dies_with { $obj->arrayref_field(qr/foo?/) } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (regexp ref)'; dies_with { $obj->arrayref_field(\[]) } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (scalarref)'; dies_with { $obj->arrayref_field('foobar') } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (string)'; dies_with { $obj->arrayref_field('123') } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (string arrayref)'; dies_with { $obj->arrayref_field(123.3) } qr/fail0r: bad arguments, expected/, 'arrayref_field negative (float)'; dies_with { $obj->hashref_field(1) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (bare number)'; no_die { $obj->hashref_field({}) } 'hashref_field positive (hashref)'; dies_with { $obj->hashref_field([]) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (arrayref)'; dies_with { $obj->hashref_field(sub {}) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (coderef)'; dies_with { $obj->hashref_field(\*foo) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (globref)'; dies_with { $obj->hashref_field(qr/foo?/) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (regexp ref)'; dies_with { $obj->hashref_field(bless([], 'foo')) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (object)'; dies_with { $obj->hashref_field(\[]) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (scalarref)'; dies_with { $obj->hashref_field('foobar') } qr/fail0r: bad arguments, expected/, 'hashref_field negative (string)'; dies_with { $obj->hashref_field('123') } qr/fail0r: bad arguments, expected/, 'hashref_field negative (string hashref)'; dies_with { $obj->hashref_field(123.3) } qr/fail0r: bad arguments, expected/, 'hashref_field negative (float)'; dies_with { $obj->coderef_field(1) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (bare number)'; no_die { $obj->coderef_field(sub {}) } 'coderef_field positive (coderef)'; dies_with { $obj->coderef_field([]) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (arrayref)'; dies_with { $obj->coderef_field({}) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (hashref)'; dies_with { $obj->coderef_field(\*foo) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (globref)'; dies_with { $obj->coderef_field(qr/foo?/) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (regexp ref)'; dies_with { $obj->coderef_field(bless([], 'foo')) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (object)'; dies_with { $obj->coderef_field(\[]) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (scalarref)'; dies_with { $obj->coderef_field('foobar') } qr/fail0r: bad arguments, expected/, 'coderef_field negative (string)'; dies_with { $obj->coderef_field('123') } qr/fail0r: bad arguments, expected/, 'coderef_field negative (string coderef)'; dies_with { $obj->coderef_field(123.3) } qr/fail0r: bad arguments, expected/, 'coderef_field negative (float)'; dies_with { $obj->object_field(1) } qr/fail0r: bad arguments, expected/, 'object_field negative (bare number)'; no_die { $obj->object_field(bless {}, 'foo') } 'object_field positive (object)'; no_die { $obj->object_field(qr/foo?/) } 'object_field positive (regexp ref)'; dies_with { $obj->object_field([]) } qr/fail0r: bad arguments, expected/, 'object_field negative (arrayref)'; dies_with { $obj->object_field({}) } qr/fail0r: bad arguments, expected/, 'object_field negative (hashref)'; dies_with { $obj->object_field(\*foo) } qr/fail0r: bad arguments, expected/, 'object_field negative (globref)'; dies_with { $obj->object_field(sub {}) } qr/fail0r: bad arguments, expected/, 'object_field negative (coderef)'; dies_with { $obj->object_field(\[]) } qr/fail0r: bad arguments, expected/, 'object_field negative (scalarref)'; dies_with { $obj->object_field('foobar') } qr/fail0r: bad arguments, expected/, 'object_field negative (string)'; dies_with { $obj->object_field('123') } qr/fail0r: bad arguments, expected/, 'object_field negative (string object)'; dies_with { $obj->object_field(123.3) } qr/fail0r: bad arguments, expected/, 'object_field negative (float)'; dies_with { $obj->regexpref_field(1) } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (bare number)'; no_die { $obj->regexpref_field(qr/foo?/) } 'regexpref_field positive (regexpref)'; dies_with { $obj->regexpref_field([]) } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (arrayref)'; dies_with { $obj->regexpref_field({}) } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (hashref)'; dies_with { $obj->regexpref_field(\*foo) } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (globref)'; dies_with { $obj->regexpref_field(bless [], 'foo') } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (regexp ref)'; dies_with { $obj->regexpref_field(sub {}) } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (coderef)'; dies_with { $obj->regexpref_field(\[]) } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (scalarref)'; dies_with { $obj->regexpref_field('foobar') } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (string)'; dies_with { $obj->regexpref_field('123') } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (string regexpref)'; dies_with { $obj->regexpref_field(123.3) } qr/fail0r: bad arguments, expected/, 'regexpref_field negative (float)'; no_die { $obj->any_field(1) } 'any_field positive (bare number)'; no_die { $obj->any_field(qr/foo?/) } 'any_field positive (any)'; no_die { $obj->any_field([]) } 'any_field positive (arrayref)'; no_die { $obj->any_field({}) } 'any_field positive (hashref)'; no_die { $obj->any_field(\*foo) } 'any_field positive (globref)'; no_die { $obj->any_field(bless [], 'foo') } 'any_field positive (regexp ref)'; no_die { $obj->any_field(sub {}) } 'any_field positive (coderef)'; no_die { $obj->any_field(\[]) } 'any_field positive (scalarref)'; no_die { $obj->any_field('foobar') } 'any_field positive (string)'; no_die { $obj->any_field('123') } 'any_field positive (string any)'; no_die { $obj->any_field(123.3) } 'any_field positive (float)'; BEGIN { my $test_class2 = <<'HERE'; package Class::CompiledCTest2; use overload; use base 'Class::CompiledC'; sub foo : Field(String); sub not_there : Abstract; sub bar : Alias(\&foo); sub eternal : Const('foobar'); sub concat : Overload(+) { my $self = shift; $self->foo($self->foo . shift) } HERE eval $test_class2; } $obj = Class::CompiledCTest2->new(); $obj->foo('8472'); is($obj->bar, '8472', 'test alias trait'); dies_with { $obj->not_there; } qr/not implemented/i, 'test Abstract trait'; is($obj->eternal, 'foobar', 'test Const trait'); $obj + 'foo'; is($obj->foo, '8472foo', 'test Overload trait'); $obj = Class::CompiledCTest->new; $obj->int_field(1); $obj->float_field(1.2); $obj->number_field(1.2); $obj->string_field('foo'); $obj->ref_field([]); $obj->arrayref_field([]); $obj->hashref_field({}); $obj->coderef_field(sub {}); $obj->object_field(bless [], 'foo'); $obj->regexpref_field(qr/foo?/); $obj->any_field('something'); ok(defined $obj->int_field(), 'int_field sanity checks'); ok(defined $obj->float_field(), 'float_field sanity checks'); ok(defined $obj->number_field(), 'number_field sanity checks'); ok(defined $obj->string_field(), 'string_field sanity checks'); ok(defined $obj->ref_field(), 'ref_field sanity checks'); ok(defined $obj->arrayref_field(), 'arrayref_field sanity checks'); ok(defined $obj->hashref_field(), 'hashref_field sanity checks'); ok(defined $obj->coderef_field(), 'coderef_field sanity checks'); ok(defined $obj->object_field(), 'object_field sanity checks'); ok(defined $obj->regexpref_field(), 'regexpref_field sanity checks'); ok(defined $obj->any_field(), 'any_field sanity checks'); my $fields = $obj->inspect; my $ref = { int_field => 'Int', float_field => 'Float', number_field => 'Number', string_field => 'String', ref_field => 'Ref', arrayref_field => 'Arrayref', hashref_field => 'Hashref', coderef_field => 'Coderef', object_field => 'Object', regexpref_field => 'Regexpref', any_field => 'Any', }; is_deeply($fields, $ref, 'test inspect method');