├── .gitignore ├── README.md ├── bin └── cor ├── dist.ini ├── lib ├── Cor.pm └── Cor │ ├── Compiler.pm │ ├── Compiler │ ├── Traits.pm │ ├── Unit.pm │ └── Unit │ │ ├── Class.pm │ │ └── Role.pm │ ├── Evaluator.pm │ ├── Parser.pm │ └── Parser │ ├── AST │ ├── Attribute.pm │ ├── Class.pm │ ├── Constant.pm │ ├── Document.pm │ ├── Location.pm │ ├── Method.pm │ ├── Method │ │ ├── Body.pm │ │ └── Signature.pm │ ├── Module.pm │ ├── Reference.pm │ ├── Role.pm │ ├── Role │ │ ├── HasAttributes.pm │ │ └── HasLocation.pm │ ├── Slot.pm │ └── TypeReference.pm │ ├── ASTBuilder.pm │ └── ASTDumper.pm ├── t ├── 000-load.t ├── 001-basic.t ├── 002-basic-dump.t ├── 010-compiler.t ├── 011-compiler-w-multiple-units.t ├── 015-compiler-errors.t ├── 020-load-from-disk.t ├── 021-load-from-disk.t ├── 022-load-from-disk.t ├── 023-load-from-disk.t └── lib │ ├── Collections │ ├── LinkedList.pm │ └── LinkedList │ │ └── Node.pm │ ├── Comparable.pm │ ├── Currency │ └── USD.pm │ ├── Data │ └── BinaryTree.pm │ ├── Eq.pm │ ├── Finance │ ├── BankAccount.pm │ └── CheckingAccount.pm │ └── Printable.pm └── weaver.ini /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.pmc 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Cor 2 | 3 | Initial prototype of Cor Object System for Perl 4 | -------------------------------------------------------------------------------- /bin/cor: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ signatures postderef ]; 6 | 7 | use Cor; 8 | 9 | main( @ARGV ); 10 | 11 | sub main (@argv) { 12 | 13 | return unless @argv; 14 | 15 | if ( $argv[0] eq '--module' ) { 16 | my $module = $argv[1]; 17 | Cor::build_module( $module, recurse => 1 ); 18 | } 19 | else { 20 | my @packages = @argv; 21 | 22 | foreach my $package ( @packages ) { 23 | Cor::build( $package, recurse => 1 ); 24 | } 25 | } 26 | 27 | return 1; 28 | } 29 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Cor 2 | author = Stevan Little 3 | license = Perl_5 4 | copyright_holder = Stevan Little 5 | copyright_year = 2020 6 | 7 | version = 0.01 8 | 9 | [@Basic] 10 | 11 | [TestRelease] 12 | [ConfirmRelease] 13 | [MetaJSON] 14 | 15 | [MetaResources] 16 | repository.url = https://github.com/stevan/Cor.git 17 | repository.web = https://github.com/stevan/Cor 18 | repository.type = git 19 | 20 | [Prereqs] 21 | perl = v5.24.0 22 | UNIVERSAL::Object = 0 23 | MOP = 0 24 | decorators = 0 25 | parent = 0 26 | slots = 0 27 | roles = 0 28 | experimental = 0 29 | PPR = 0 30 | Module::Runtime = 0 31 | List::Util = 0 32 | Scalar::Util = 0 33 | Data::Dumper = 0 34 | IO::File = 0 35 | File::Spec = 0 36 | 37 | [Prereqs / TestRequires] 38 | Test::More = 0 39 | Test::Differences = 0 40 | -------------------------------------------------------------------------------- /lib/Cor.pm: -------------------------------------------------------------------------------- 1 | package Cor; 2 | # ABSTRACT: A core object system for Perl 5 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | 8 | use IO::File (); 9 | use IO::Dir (); 10 | use File::Spec (); 11 | use Module::Runtime (); 12 | 13 | use Cor::Parser; 14 | use Cor::Compiler; 15 | 16 | use constant DEBUG => $ENV{COR_DEBUG} // 0; 17 | 18 | our %COR_INC; 19 | 20 | sub build_module ($module, %opts) { 21 | 22 | my ($module_root, $module_dir) = find_module_path_in_INC( $module ); 23 | 24 | warn "Building module [$module]($module_dir) in ($module_root)\n" if DEBUG; 25 | 26 | $module_root = File::Spec->catfile( $module_root ); # clean this to be like module_path 27 | my $module_path = File::Spec->catfile( $module_root, $module_dir ); 28 | 29 | my @contents = find_module_contents( $module_path ); 30 | 31 | #use Data::Dumper; 32 | #warn Dumper \@contents; 33 | 34 | my %packages = map { 35 | # strip off the module package 36 | s/$module\:\://r => $_ 37 | } map { 38 | s/^$module_root\///; # strip off the root directory 39 | s/\.pm$//; # strip off the file extension 40 | s/\//\:\:/gr; # transform path (/) to package (::) 41 | } @contents; 42 | 43 | #warn $module_root; 44 | #warn $module_dir; 45 | #warn $module_path; 46 | #use Data::Dumper; 47 | #warn Dumper \%packages; 48 | 49 | my @built; 50 | foreach my $k ( keys %packages ) { 51 | push @built => build( $packages{ $k }, %opts, module_map => \%packages ); 52 | } 53 | 54 | return @built; 55 | } 56 | 57 | sub find_module_contents ($module_dir) { 58 | 59 | my @contents; 60 | 61 | my $dir = IO::Dir->new( $module_dir ); 62 | 63 | while ( my $child = $dir->read ) { 64 | next if $child =~ /^\./; 65 | 66 | my $child_path = File::Spec->catfile( $module_dir, $child ); 67 | 68 | if ( -f $child_path ) { 69 | next unless $child =~ /\.pm$/; 70 | push @contents => $child_path; 71 | } 72 | elsif ( -d $child_path ) { 73 | push @contents => find_module_contents( $child_path ); 74 | } 75 | else { 76 | # ignore anything else for now 77 | } 78 | } 79 | 80 | return @contents; 81 | } 82 | 83 | sub build ($resource, %opts) { 84 | 85 | my ($package_dir, $package_path) = find_path_in_INC( $resource ); 86 | 87 | die "Could not find [$resource] in \@INC paths" 88 | unless defined $package_dir; 89 | 90 | if ( exists $COR_INC{ $package_path } ) { 91 | warn "Skipping [$resource]($package_path) it was already built\n" if DEBUG; 92 | return; 93 | } 94 | 95 | warn "Building [$resource]($package_path) in ($package_dir)\n" if DEBUG; 96 | 97 | my $full_package_path = File::Spec->catfile( $package_dir, $package_path ); 98 | 99 | my $original = read_source_file( $full_package_path ); 100 | my $doc = Cor::Parser::parse( $original ); 101 | my $compiler = Cor::Compiler->new( 102 | doc => $doc, 103 | (exists $opts{module_map} 104 | ? (module_map => $opts{module_map}) 105 | : ()) 106 | ); 107 | 108 | #use Data::Dumper; warn Dumper $asts; 109 | 110 | my @built; 111 | 112 | if ( $opts{recurse} ) { 113 | my @dependencies = $compiler->list_dependencies; 114 | foreach my $dep ( @dependencies ) { 115 | push @built => build( $dep, %opts ); 116 | } 117 | } 118 | 119 | my $compiled = $compiler->compile; 120 | 121 | my $pmc_file_path = write_pmc_file( $full_package_path, $compiled ); 122 | 123 | $COR_INC{ $package_path } = $pmc_file_path; 124 | 125 | return @built, $pmc_file_path; 126 | } 127 | 128 | sub find_path_in_INC ($resource) { 129 | 130 | use Carp (); 131 | Carp::confess("WTF") unless defined $resource; 132 | 133 | my @inc = @INC; 134 | 135 | my $package_path; 136 | 137 | if ( Module::Runtime::is_module_name( $resource ) ) { 138 | $package_path = Module::Runtime::module_notional_filename( $resource ); 139 | } 140 | else { 141 | $package_path = $resource; 142 | } 143 | 144 | my $inc; 145 | while ( $inc = shift @inc ) { 146 | next if ref $inc; # skip them for now ... 147 | # jump out of loop if we found it 148 | last if -f File::Spec->catfile( $inc, $package_path ); 149 | } 150 | 151 | return ($inc, $package_path); 152 | } 153 | 154 | sub find_module_path_in_INC ($resource) { 155 | my @inc = @INC; 156 | 157 | my $module_path; 158 | 159 | if ( Module::Runtime::is_module_name( $resource ) ) { 160 | $module_path = Module::Runtime::module_notional_filename( $resource ); 161 | $module_path =~ s/\.pm$//; 162 | } 163 | else { 164 | $module_path = $resource; 165 | } 166 | 167 | my $inc; 168 | while ( $inc = shift @inc ) { 169 | next if ref $inc; # skip them for now ... 170 | # jump out of loop if we found it 171 | last if -d File::Spec->catfile( $inc, $module_path ); 172 | } 173 | 174 | return ($inc, $module_path); 175 | } 176 | 177 | sub read_source_file ($full_package_path) { 178 | 179 | my $fh = IO::File->new; 180 | $fh->open( $full_package_path, 'r' ) 181 | or die "Could not open [$full_package_path] because [$!]"; 182 | my $source = join '' => <$fh>; 183 | $fh->close 184 | or die "Could not close [$full_package_path] because [$!]"; 185 | 186 | return $source; 187 | } 188 | 189 | sub write_pmc_file ($full_package_path, $compiled) { 190 | my $pmc_path = $full_package_path.'c'; 191 | 192 | my $pmc = IO::File->new; 193 | $pmc->open( $pmc_path, 'w' ) 194 | or die "Could not open [$pmc_path] because [$!]"; 195 | $pmc->print($compiled); 196 | $pmc->close 197 | or die "Could not close [$pmc_path] because [$!]";; 198 | 199 | return $pmc_path; 200 | } 201 | 202 | 1; 203 | 204 | __END__ 205 | 206 | =pod 207 | 208 | =cut 209 | -------------------------------------------------------------------------------- /lib/Cor/Compiler.pm: -------------------------------------------------------------------------------- 1 | package Cor::Compiler; 2 | # ABSTRACT: Compiler for Cor object 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | 8 | use Cor::Compiler::Unit::Role; 9 | use Cor::Compiler::Unit::Class; 10 | 11 | use Cor::Compiler::Traits; 12 | 13 | use parent 'UNIVERSAL::Object'; 14 | 15 | use slots ( 16 | doc => sub {}, 17 | traits => sub { +{} }, 18 | module_map => sub { +{} }, 19 | # ... 20 | _units => sub {}, 21 | _dependencies => sub {}, 22 | ); 23 | 24 | sub BUILD ($self, $params) { 25 | 26 | my @asts = $self->{doc}->asts->@*; 27 | my %package_index = map { $_->name => undef } @asts; 28 | 29 | # combine user supplied traits with core ones ... 30 | my %traits = ( $self->{traits}->%*, %Cor::Compiler::Traits::TRAITS ); 31 | 32 | my @units = map { 33 | $_->isa('Cor::Parser::AST::Class') 34 | ? Cor::Compiler::Unit::Class->new( ast => $_, traits => \%traits, module_map => $self->{module_map} ) 35 | : Cor::Compiler::Unit::Role->new( ast => $_, traits => \%traits, module_map => $self->{module_map} ) 36 | } @asts; 37 | 38 | my @dependencies = map { 39 | # transform the dependency name 40 | # based on the module mapping 41 | $_->set_name( $self->{module_map}->{ $_->name } ) 42 | if exists $self->{module_map}->{ $_->name }; 43 | # return the item 44 | $_; 45 | } map { 46 | # filter out any dependencies contained 47 | # here in this compilation group ... 48 | (grep not( exists $package_index{ $_->name } ), $_->dependencies) 49 | } @units; 50 | 51 | #use Data::Dumper; 52 | #warn Dumper \@dependencies; 53 | 54 | $self->{_units} = \@units; 55 | $self->{_dependencies} = \@dependencies; 56 | } 57 | 58 | sub list_dependencies ($self) { map $_->name, $self->{_dependencies}->@* } 59 | 60 | sub compile ($self) { 61 | 62 | my @compiled; 63 | 64 | push @compiled => $self->{doc}->use_statements->@*; 65 | push @compiled => map { 'use '.$_->name.';' } $self->{_dependencies}->@*; 66 | push @compiled => map $_->generate_source, $self->{_units}->@*; 67 | 68 | return join "\n" => @compiled; 69 | } 70 | 71 | 1; 72 | 73 | __END__ 74 | 75 | =pod 76 | 77 | =cut 78 | -------------------------------------------------------------------------------- /lib/Cor/Compiler/Traits.pm: -------------------------------------------------------------------------------- 1 | package Cor::Compiler::Traits; 2 | # ABSTRACT: The set of core traits for Cor 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | 8 | our %TRAITS; 9 | BEGIN { 10 | 11 | %TRAITS = ( 12 | 'reader' => sub ( $meta, $item, $attribute ) { 13 | 14 | my ($method, $slot_name); 15 | if ( $item->isa('Cor::Parser::AST::Method') ) { 16 | $method = $item; 17 | # it is no longer abstract ... 18 | $method->set_is_abstract(0); 19 | # we expect the slot name to be passed ... 20 | $slot_name = $attribute->args; 21 | } 22 | elsif ( $item->isa('Cor::Parser::AST::Slot') ) { 23 | # create a method ... 24 | $method = Cor::Parser::ASTBuilder::new_method_at( -1 ); 25 | 26 | # give it a name 27 | my $name = $attribute->has_args 28 | ? $attribute->args 29 | : $item->identifier; 30 | $method->set_name( $name ); 31 | 32 | # now set the slot name ... 33 | $slot_name = $item->name; 34 | 35 | # make sure to add method to the class 36 | $meta->add_method( $method ); 37 | } 38 | else { 39 | die "WTF! $item"; 40 | } 41 | 42 | $method->set_signature( 43 | Cor::Parser::ASTBuilder::create_method_signature( [ '$self' ] ) 44 | ); 45 | $method->set_body( 46 | Cor::Parser::ASTBuilder::create_method_body( 47 | '{ $self->{q['.$slot_name.']} }', 48 | ) 49 | ); 50 | return 1; 51 | }, 52 | 'writer' => sub ( $meta, $item, $attribute ) { 53 | 54 | my ($method, $slot_name); 55 | if ( $item->isa('Cor::Parser::AST::Method') ) { 56 | $method = $item; 57 | # it is no longer abstract ... 58 | $method->set_is_abstract(0); 59 | # we expect the slot name to be passed ... 60 | $slot_name = $attribute->args; 61 | } 62 | elsif ( $item->isa('Cor::Parser::AST::Slot') ) { 63 | # create a method ... 64 | $method = Cor::Parser::ASTBuilder::new_method_at( -1 ); 65 | 66 | # give it a name 67 | my $name = $attribute->has_args 68 | ? $attribute->args 69 | : $item->identifier; 70 | $method->set_name( $name ); 71 | 72 | # now set the slot name ... 73 | $slot_name = $item->name; 74 | 75 | # make sure to add method to the class 76 | $meta->add_method( $method ); 77 | } 78 | else { 79 | die "WTF! $item"; 80 | } 81 | 82 | $method->set_signature( 83 | Cor::Parser::ASTBuilder::create_method_signature( [ '$self', '$arg' ] ) 84 | ); 85 | $method->set_body( 86 | Cor::Parser::ASTBuilder::create_method_body( 87 | '{ $self->{q['.$slot_name.']} = $arg }', 88 | ) 89 | ); 90 | return 1; 91 | }, 92 | 'accessor' => sub ( $meta, $item, $attribute ) { 93 | 94 | my ($method, $slot_name); 95 | if ( $item->isa('Cor::Parser::AST::Method') ) { 96 | $method = $item; 97 | # it is no longer abstract ... 98 | $method->set_is_abstract(0); 99 | # we expect the slot name to be passed ... 100 | $slot_name = $attribute->args; 101 | } 102 | elsif ( $item->isa('Cor::Parser::AST::Slot') ) { 103 | # create a method ... 104 | $method = Cor::Parser::ASTBuilder::new_method_at( -1 ); 105 | 106 | # give it a name 107 | my $name = $attribute->has_args 108 | ? $attribute->args 109 | : $item->identifier; 110 | $method->set_name( $name ); 111 | 112 | # now set the slot name ... 113 | $slot_name = $item->name; 114 | 115 | # make sure to add method to the class 116 | $meta->add_method( $method ); 117 | } 118 | else { 119 | die "WTF! $item"; 120 | } 121 | 122 | $method->set_signature( 123 | Cor::Parser::ASTBuilder::create_method_signature( [ '$self', '@args' ] ) 124 | ); 125 | $method->set_body( 126 | Cor::Parser::ASTBuilder::create_method_body( 127 | '{ $self->{q['.$slot_name.']} = $args[0] if @args; $self->{q['.$slot_name.']}; }', 128 | ) 129 | ); 130 | return 1; 131 | }, 132 | 'predicate' => sub ( $meta, $item, $attribute ) { 133 | 134 | my ($method, $slot_name); 135 | if ( $item->isa('Cor::Parser::AST::Method') ) { 136 | $method = $item; 137 | # it is no longer abstract ... 138 | $method->set_is_abstract(0); 139 | # we expect the slot name to be passed ... 140 | $slot_name = $attribute->args; 141 | } 142 | elsif ( $item->isa('Cor::Parser::AST::Slot') ) { 143 | # create a method ... 144 | $method = Cor::Parser::ASTBuilder::new_method_at( -1 ); 145 | 146 | # give it a name 147 | my $name; 148 | if ($attribute->has_args) { 149 | $name = $attribute->args; 150 | } 151 | else { 152 | $name = $item->identifier; 153 | $name = 'has_' . $name; 154 | } 155 | $method->set_name( $name ); 156 | 157 | # now set the slot name ... 158 | $slot_name = $item->name; 159 | 160 | # make sure to add method to the class 161 | $meta->add_method( $method ); 162 | } 163 | else { 164 | die "WTF! $item"; 165 | } 166 | 167 | $method->set_signature( 168 | Cor::Parser::ASTBuilder::create_method_signature( [ '$self' ] ) 169 | ); 170 | $method->set_body( 171 | Cor::Parser::ASTBuilder::create_method_body( 172 | '{ defined $self->{q['.$slot_name.']} }', 173 | ) 174 | ); 175 | return 1; 176 | }, 177 | ); 178 | 179 | # simple aliases 180 | $TRAITS{ro} = $TRAITS{reader}; 181 | $TRAITS{rw} = $TRAITS{accessor}; 182 | $TRAITS{wo} = $TRAITS{writer}; 183 | } 184 | 185 | 1; 186 | 187 | __END__ 188 | 189 | =pod 190 | 191 | =cut 192 | -------------------------------------------------------------------------------- /lib/Cor/Compiler/Unit.pm: -------------------------------------------------------------------------------- 1 | package Cor::Compiler::Unit; 2 | # ABSTRACT: Role representing a compilation unit 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures ]; 7 | 8 | use slots ( 9 | ast => sub {}, 10 | traits => sub { +{} }, 11 | module_map => sub { +{} }, 12 | ); 13 | 14 | sub generate_source; 15 | 16 | sub dependencies; 17 | 18 | 1; 19 | 20 | __END__ 21 | 22 | =pod 23 | 24 | =cut 25 | -------------------------------------------------------------------------------- /lib/Cor/Compiler/Unit/Class.pm: -------------------------------------------------------------------------------- 1 | package Cor::Compiler::Unit::Class; 2 | # ABSTRACT: compilation unit for classes 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | 8 | use parent 'Cor::Compiler::Unit::Role'; 9 | 10 | use slots; 11 | 12 | sub dependencies ($self) { 13 | return $self->next::method, $self->{ast}->superclasses->@* 14 | } 15 | 16 | sub preamble ($self) { 17 | return ( 18 | $self->next::method, 19 | # make sure UNIVERSAL::Object is loaded 20 | # if we are going to make use of it 21 | (scalar $self->{ast}->superclasses->@* == 0 22 | ? 'use UNIVERSAL::Object;' 23 | : ()), 24 | $self->generate_superclasses, 25 | $self->generate_constructor, 26 | ) 27 | } 28 | 29 | sub generate_constructor ($self) { 30 | my $meta = $self->{ast}; 31 | 32 | # no slots and no supers 33 | # means we have no need for 34 | # a BUILDARGS to be generated 35 | return if not( $meta->has_slots ) 36 | && not( $meta->has_superclasses ); 37 | 38 | my %map = map { $_->identifier => $_ } $meta->slots->@*; 39 | 40 | my @src; 41 | push @src => '# constructor'; 42 | push @src => 'sub BUILDARGS ($class, %args) {'; 43 | push @src => 'my %proto;'; 44 | 45 | if ( $meta->has_superclasses ) { 46 | # NOTE: 47 | # This is a dangerous assumption 48 | # about the parent BUILDARGS method 49 | # we will need to be smarter here 50 | # - SL 51 | push @src => '%proto = $class->next::method( %args )->%*;' 52 | } 53 | 54 | foreach my $param ( sort keys %map ) { 55 | 56 | my $slot = $map{$param}; 57 | 58 | if ( 59 | ($slot->has_attributes && $slot->has_attribute('private')) 60 | || 61 | ($slot->name =~ /^\$\!/) 62 | ) { 63 | push @src => 'die \'Illegal Arg: `'.$param.'` is a private slot\' if exists $args{q['.$param.']};'; 64 | } 65 | else { 66 | push @src => '$proto{q['.$slot->name.']} = $args{q['.$param.']} if exists $args{q['.$param.']};' 67 | } 68 | } 69 | push @src => 'return \%proto;'; 70 | push @src => '}'; 71 | return @src; 72 | } 73 | 74 | sub generate_superclass_reference_name ($self, $reference) { 75 | 76 | my $name; 77 | if ( $reference->has_module && exists $self->{module_map}->{ $reference->name } ) { 78 | $name = $reference->module->name . '::' . $reference->name; 79 | } 80 | else { 81 | $name = $reference->name; 82 | } 83 | 84 | return $name; 85 | } 86 | 87 | sub generate_superclasses ($self) { 88 | my $meta = $self->{ast}; 89 | 90 | my @superclasses = map $self->generate_superclass_reference_name( $_ ), $self->{ast}->superclasses->@*; 91 | 92 | # if there is no superclass ... 93 | if ( scalar @superclasses == 0 ) { 94 | # make it a UNIVERSAL::Object subclass 95 | push @superclasses => 'UNIVERSAL::Object'; 96 | } 97 | 98 | my @src; 99 | push @src => '# superclasses'; 100 | push @src => 'our @ISA; BEGIN { @ISA = qw['.(join ' ' => @superclasses).'] }'; 101 | return @src; 102 | } 103 | 104 | sub generate_slots ($self) { 105 | my $meta = $self->{ast}; 106 | my @src = $self->next::method(); 107 | 108 | # inherit the slots at compile time ... 109 | if ( my @superclasses = map $self->generate_superclass_reference_name( $_ ), $self->{ast}->superclasses->@* ) { 110 | my $close = pop @src; 111 | push @src => map { 112 | ' %'.$_.'::HAS,' 113 | } @superclasses; 114 | push @src => $close; 115 | } 116 | 117 | return @src; 118 | } 119 | 120 | 1; 121 | 122 | __END__ 123 | 124 | =pod 125 | 126 | =cut 127 | -------------------------------------------------------------------------------- /lib/Cor/Compiler/Unit/Role.pm: -------------------------------------------------------------------------------- 1 | package Cor::Compiler::Unit::Role; 2 | # ABSTRACT: compilation unit for roles 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | 8 | use parent 'UNIVERSAL::Object'; 9 | use roles 'Cor::Compiler::Unit'; 10 | 11 | use slots ( 12 | # ... 13 | _UNITCHECK => sub { [] } 14 | ); 15 | 16 | sub dependencies ($self) { 17 | return $self->{ast}->roles->@* 18 | } 19 | 20 | sub preamble ($self) { 21 | return ( 22 | 'use v5.24;', 23 | 'use warnings;', 24 | 'use experimental qw[ signatures ];', 25 | 'use MOP;', 26 | 'use roles ();', # for roles::DOES ... 27 | ) 28 | } 29 | 30 | sub generate_source ($self) { 31 | 32 | my $meta = $self->{ast}; 33 | 34 | # apply the traits 35 | 36 | # NOTE: 37 | # this needs to happen before we do anything 38 | # else, because this may result in a modification 39 | # of the AST object, which then affects the 40 | # generated source. 41 | # - SL 42 | 43 | foreach my $slot ( $meta->slots->@* ) { 44 | if ( $slot->has_attributes ) { 45 | my @attributes; 46 | foreach my $attribute ( $slot->attributes->@* ) { 47 | if ( not $self->_apply_trait( $meta, $slot, $attribute ) ) { 48 | push @attributes => $attribute; 49 | } 50 | } 51 | $slot->set_attributes( \@attributes ); 52 | } 53 | } 54 | 55 | foreach my $method ( $meta->methods->@* ) { 56 | if ( $method->has_attributes ) { 57 | my @attributes; 58 | foreach my $attribute ( $method->attributes->@* ) { 59 | if ( not $self->_apply_trait( $meta, $method, $attribute ) ) { 60 | push @attributes => $attribute; 61 | } 62 | } 63 | $method->set_attributes( \@attributes ); 64 | } 65 | } 66 | 67 | # ... generate source 68 | 69 | my @src; 70 | 71 | push @src => 'package ' 72 | . $self->generate_package_name 73 | . ($meta->has_version ? ' ' . ($meta->version =~ s/^v//r) : '') 74 | . ' {'; 75 | 76 | push @src => $self->preamble; 77 | 78 | 79 | if ( $meta->has_roles ) { 80 | push @src => $self->generate_roles; 81 | } 82 | 83 | if ( $meta->has_constants ) { 84 | push @src => $self->generate_constants; 85 | } 86 | 87 | if ( $meta->has_slots ) { 88 | push @src => $self->generate_slots; 89 | } 90 | 91 | if ( $meta->has_methods ) { 92 | push @src => $self->generate_methods; 93 | } 94 | 95 | if ( $meta->has_roles ) { 96 | push @src => '# finalize'; 97 | push @src => 'BEGIN {'; 98 | push @src => 'MOP::Util::compose_roles(MOP::Util::get_meta(__PACKAGE__));'; 99 | push @src => '}'; 100 | } 101 | 102 | push @src => '1;'; 103 | push @src => '}'; 104 | 105 | return join "\n" => @src; 106 | } 107 | 108 | sub generate_package_name ($self) { 109 | my $meta = $self->{ast}; 110 | 111 | my $name; 112 | if ( $meta->has_module ) { 113 | $name = $meta->module->name . '::' . $meta->name; 114 | } 115 | else { 116 | $name = $meta->name; 117 | } 118 | 119 | return $name; 120 | } 121 | 122 | sub generate_role_reference_name ($self, $reference) { 123 | 124 | my $name; 125 | if ( $reference->has_module && exists $self->{module_map}->{ $reference->name } ) { 126 | $name = $reference->module->name . '::' . $reference->name; 127 | } 128 | else { 129 | $name = $reference->name; 130 | } 131 | 132 | return $name; 133 | } 134 | 135 | sub generate_constants ($self) { 136 | my $meta = $self->{ast}; 137 | 138 | my @src; 139 | push @src => '# constants'; 140 | push @src => map { 141 | ('use constant ' . $_->name . ' => (' . $_->value . ');') 142 | } $meta->constants->@*; 143 | return @src; 144 | } 145 | 146 | sub generate_roles ($self) { 147 | my $meta = $self->{ast}; 148 | 149 | my @src; 150 | push @src => '# roles'; 151 | push @src => 'our @DOES; BEGIN { @DOES = qw[' 152 | .(join ' ' => map $self->generate_role_reference_name( $_ ), $meta->roles->@*) 153 | .'] }'; 154 | return @src; 155 | } 156 | 157 | sub generate_slots ($self) { 158 | my $meta = $self->{ast}; 159 | 160 | my @src; 161 | push @src => '# slots'; 162 | push @src => 'our %HAS; BEGIN { %HAS = ('; 163 | push @src => map { 164 | ' q[' . $_->name . '] => sub { ' . ($_->has_default ? $_->default : '') . ' },' 165 | } $meta->slots->@*; 166 | push @src => ') }'; 167 | return @src; 168 | } 169 | 170 | sub generate_methods ($self) { 171 | my $meta = $self->{ast}; 172 | 173 | my (@methods, @private_methods); 174 | foreach my $method ( $meta->methods->@* ) { 175 | if ( $method->has_attributes && $method->has_attribute('private') ) { 176 | push @private_methods => $method; 177 | } 178 | else { 179 | push @methods => $method; 180 | } 181 | } 182 | 183 | my %private_method_index = map { $_->name => undef } @private_methods; 184 | 185 | #use Data::Dumper; 186 | #warn Dumper \%private_method_index; 187 | 188 | my @src; 189 | 190 | if ( @private_methods ) { 191 | push @src => '# private methods'; 192 | 193 | foreach my $method ( @private_methods ) { 194 | push @src => 195 | 'my $___' . $method->name . ' = sub' 196 | . $self->_compile_method_signature( $method ) 197 | . ' ' . $self->_compile_method_body( $method->body, \%private_method_index ) 198 | . ';'; 199 | } 200 | } 201 | 202 | if ( @methods ) { 203 | push @src => '# methods'; 204 | 205 | foreach my $method ( @methods ) { 206 | push @src => 207 | 'sub ' 208 | . $method->name 209 | . ($method->has_attributes 210 | ? ' ' . ( 211 | join ' ' => map { 212 | ':'.$_->name.'('.$_->args.')' 213 | } $method->attributes->@* 214 | ) 215 | : '') 216 | . $self->_compile_method_signature( $method ) 217 | . ($method->is_abstract 218 | ? ';' 219 | : ' ' . $self->_compile_method_body( $method->body, \%private_method_index )); 220 | } 221 | } 222 | 223 | return @src; 224 | } 225 | 226 | # ... 227 | 228 | sub _apply_trait ( $self, $meta, $topic, $attribute ) { 229 | if ( my $trait = $self->{traits}->{ $attribute->name } ) { 230 | $trait->( $meta, $topic, $attribute ); 231 | } 232 | } 233 | 234 | sub _compile_method_signature ($self, $method) { 235 | 236 | return '' if $method->is_abstract; 237 | 238 | my @args; 239 | 240 | if ( $method->has_signature ) { 241 | @args = $method->signature->arguments->@*; 242 | } 243 | 244 | if ( scalar @args == 0 ) { 245 | unshift @args => '$self'; 246 | } 247 | 248 | if ($args[0] ne '$self') { 249 | unshift @args => '$self'; 250 | } 251 | 252 | return ' (' . (join ', ' => @args) . ')'; 253 | 254 | } 255 | 256 | sub _compile_method_body ($self, $body, $private_method_index) { 257 | 258 | my $source = $body->source; 259 | my $offset = 0; 260 | 261 | if ( my @slot_matches = $body->slot_locations->@* ) { 262 | 263 | foreach my $m ( @slot_matches ) { 264 | # FIXME: 265 | # this is not ideal, it assumes that @_ 266 | # is available, and in newer versions of 267 | # perl, this may not always be the case 268 | # so I think we need to make some kind 269 | # of other arrangements. 270 | # - SL 271 | my $patch = '$self->{q[' . $m->{match} . ']}'; 272 | 273 | #use Data::Dumper; 274 | #warn Dumper [ $m, [ 275 | # $source, 276 | # length( $source ), 277 | # $m->{start} + $offset, 278 | # length( $m->{match} ) 279 | # ] ]; 280 | 281 | substr( 282 | $source, 283 | $m->{start} + $offset, 284 | length( $m->{match} ), 285 | ) = $patch; 286 | $offset += length( $patch ) - length( $m->{match} ); 287 | } 288 | 289 | } 290 | 291 | if ( my @self_call_matches = $body->self_call_locations->@* ) { 292 | 293 | foreach my $m ( @self_call_matches ) { 294 | 295 | # only compile private methods ... 296 | next unless exists $private_method_index->{ $m->{match} }; 297 | 298 | my $patch = '$___' . $m->{match}; 299 | 300 | #use Data::Dumper; 301 | #warn Dumper [ $m, [ 302 | # $source, 303 | # length( $source ), 304 | # $m->{start} + $offset, 305 | # length( $m->{match} ) 306 | # ] ]; 307 | 308 | substr( 309 | $source, 310 | $m->{start} + $offset, 311 | length( $m->{match} ), 312 | ) = $patch; 313 | $offset += length( $patch ) - length( $m->{match} ); 314 | } 315 | 316 | } 317 | 318 | if ( my @class_usage_matches = $body->class_usage_locations->@* ) { 319 | 320 | foreach my $m ( @class_usage_matches ) { 321 | 322 | next unless exists $self->{module_map}->{ $m->{match} }; 323 | 324 | my $patch = $self->{module_map}->{ $m->{match} }; 325 | 326 | substr( 327 | $source, 328 | $m->{start} + $offset, 329 | length( $m->{match} ), 330 | ) = $patch; 331 | $offset += length( $patch ) - length( $m->{match} ); 332 | } 333 | 334 | } 335 | 336 | return $source; 337 | 338 | } 339 | 340 | 1; 341 | 342 | __END__ 343 | 344 | =pod 345 | 346 | =cut 347 | -------------------------------------------------------------------------------- /lib/Cor/Evaluator.pm: -------------------------------------------------------------------------------- 1 | package Cor::Evaluator; 2 | # ABSTRACT: Simple evaluator 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | 8 | # NOTE: 9 | # this is not really meant to be an important 10 | # component, it is mostly useful for testing 11 | # when we are constructing Cor classes as strings 12 | # and want to test stuff, I would recommend to 13 | # not take it very seriously. 14 | # - SL 15 | 16 | sub evaluate ($src) { 17 | 18 | # TODO 19 | # Improve this error handling. 20 | # A lot. 21 | # - SL 22 | local $@ = undef; 23 | eval $src; 24 | if ( $@ ) { 25 | die $@; 26 | } 27 | 28 | return $src; 29 | } 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =cut 38 | -------------------------------------------------------------------------------- /lib/Cor/Parser.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser; 2 | # ABSTRACT: Parser for the Cor syntax 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | 8 | use PPR; 9 | 10 | use List::Util; 11 | 12 | use Cor::Parser::ASTBuilder; 13 | 14 | our @_COR_USE_STATEMENTS; 15 | our $_COR_CURRENT_MODULE; 16 | our $_COR_CURRENT_META; 17 | our $_COR_CURRENT_REFERENCE; 18 | our $_COR_CURRENT_CONST; 19 | our $_COR_CURRENT_SLOT; 20 | our $_COR_CURRENT_METHOD; 21 | 22 | our $COR_RULES; 23 | our $COR_GRAMMAR; 24 | 25 | BEGIN { 26 | $COR_RULES = qr{ 27 | (?(DEFINE) 28 | 29 | # --------------------------------------- 30 | # SLOTS 31 | # --------------------------------------- 32 | 33 | (? 34 | (?> 35 | (\$\!(?&PerlIdentifier)) 36 | | 37 | (\$\.(?&PerlIdentifier)) 38 | | 39 | (\$(?&PerlIdentifier)) 40 | ) 41 | ) 42 | 43 | # NOTE: 44 | # this list might not be complete, it 45 | # may be missing something valid, or 46 | # it may be including something we do 47 | # not want, but it suffices for now. 48 | # - SL 49 | (? 50 | (?> 51 | # heavy lifters ... 52 | (?&PerlAnonymousSubroutine) 53 | | (?&PerlDoBlock) 54 | | (?&PerlEvalBlock) 55 | # calling a perl function ... 56 | | (?>(?&PerlNullaryBuiltinFunction)) (?! (?>(?&PerlOWS)) \( ) 57 | # literal constructors 58 | | (?&PerlAnonymousArray) 59 | | (?&PerlAnonymousHash) 60 | | (?&PerlQuotelikeQR) 61 | | (?&PerlString) 62 | | (?&PerlNumber) 63 | ) 64 | ) 65 | 66 | (? 67 | (?> 68 | ((?&PerlIdentifier)(?&PerlOWS)\[(?&PerlOWS)(?&PerlSlotTypeName)(?&PerlOWS)\]) 69 | | 70 | (?&PerlIdentifier) 71 | ) 72 | ) 73 | 74 | (? 75 | (has) (?{ 76 | $_COR_CURRENT_SLOT = Cor::Parser::ASTBuilder::new_slot_at( pos() - length($^N) ) 77 | }) 78 | (?&PerlNWS) 79 | ( 80 | ((?&PerlSlotTypeName)) (?{ 81 | my $pos = pos(); 82 | my $name = $^N; 83 | $_COR_CURRENT_SLOT->set_type( 84 | Cor::Parser::ASTBuilder::new_type_reference( $name, $name, $pos ) 85 | ); 86 | }) 87 | (?&PerlNWS) 88 | )? 89 | ((?&PerlSlotIdentifier)) (?{ $_COR_CURRENT_SLOT->set_name( $^N ) }) 90 | (?&PerlOWS) 91 | (?: 92 | (?> 93 | ((?&PerlAttributes)) (?{ 94 | my $pos = pos(); 95 | my $attributes_src = $^N; 96 | 97 | my @attributes = Cor::Parser::ASTBuilder::new_attributes_at( 98 | _parse_attributes( $attributes_src ), 99 | $pos 100 | ); 101 | 102 | #use Data::Dumper; 103 | #warn Dumper \@attributes; 104 | 105 | $_COR_CURRENT_SLOT->set_attributes( \@attributes ) 106 | }) 107 | ) 108 | (?&PerlOWS) 109 | )?+ 110 | (?> 111 | (;) (?{ 112 | Cor::Parser::ASTBuilder::set_end_location( 113 | $_COR_CURRENT_SLOT, 114 | pos() - length($^N), 115 | ); 116 | }) 117 | | 118 | ( 119 | (?&PerlAssignmentOperator) 120 | (?&PerlOWS) 121 | ((?&PerlSlotDefault)) (?{ $_COR_CURRENT_SLOT->set_default( $^N ) }) 122 | (;) (?{ 123 | Cor::Parser::ASTBuilder::set_end_location( 124 | $_COR_CURRENT_SLOT, 125 | pos() - length($^N), 126 | ); 127 | }) 128 | ) 129 | | 130 | # TODO: 131 | # make this track location information as well 132 | (?{ 133 | die 'unable to parse slot default for `'.$_COR_CURRENT_SLOT->name.'` in class `'.$_COR_CURRENT_META->name.'`'; 134 | }) 135 | ) (?{ $_COR_CURRENT_META->add_slot( $_COR_CURRENT_SLOT ); }) 136 | ) 137 | 138 | # --------------------------------------- 139 | # METHODS 140 | # --------------------------------------- 141 | 142 | # NOTE: 143 | # define this here, not sure if we will use it 144 | # but good to have it defined differently i think 145 | # because I think we should restrict the contents 146 | # of methods to be "strict" by default, and even 147 | # maybe to not allow certain constructs. This will 148 | # require recursing down the rulesets, so defining 149 | # our own PerlMethodStatementSequence to replace 150 | # the below "PerlStatementSequence" for instance. 151 | # - SL 152 | (? 153 | \{ (?>(?&PerlStatementSequence)) \} 154 | ) 155 | 156 | (? 157 | (method) (?{ 158 | $_COR_CURRENT_METHOD = Cor::Parser::ASTBuilder::new_method_at( pos() - length($^N) ) 159 | }) 160 | (?&PerlOWS) 161 | ((?&PerlQualifiedIdentifier)) (?{ $_COR_CURRENT_METHOD->set_name( $^N ); }) 162 | (?&PerlOWS) 163 | (?: 164 | (?> 165 | ((?&PerlAttributes)) (?{ 166 | 167 | my $pos = pos(); 168 | my $attributes_src = $^N; 169 | 170 | my @attributes = Cor::Parser::ASTBuilder::new_attributes_at( 171 | _parse_attributes( $attributes_src ), 172 | $pos 173 | ); 174 | 175 | #use Data::Dumper; 176 | #warn Dumper \@attributes; 177 | 178 | $_COR_CURRENT_METHOD->set_attributes( \@attributes ) 179 | }) 180 | ) 181 | (?&PerlOWS) 182 | )?+ 183 | (?: 184 | (?> 185 | ((?&PerlParenthesesList)) (?{ 186 | 187 | my $pos = pos(); 188 | my $signature_src = $^N; 189 | 190 | my $signature = Cor::Parser::ASTBuilder::new_signature_at( 191 | _parse_signature( $signature_src ), 192 | $pos 193 | ); 194 | 195 | #use Data::Dumper; 196 | #warn Dumper $signature; 197 | 198 | $_COR_CURRENT_METHOD->set_signature( $signature ); 199 | }) 200 | ) 201 | (?&PerlOWS) 202 | )?+ 203 | (?> 204 | (\;) (?{ 205 | $_COR_CURRENT_METHOD->set_is_abstract( 1 ); 206 | 207 | Cor::Parser::ASTBuilder::set_end_location( 208 | $_COR_CURRENT_METHOD, 209 | pos() - length($^N), 210 | ); 211 | }) 212 | | 213 | ((?&PerlMethodBlock)) (?{ 214 | 215 | my $pos = pos(); 216 | my $body_src = $^N; 217 | 218 | my $body = Cor::Parser::ASTBuilder::new_method_body_at( 219 | _parse_method_body( 220 | $body_src, 221 | $_COR_CURRENT_META 222 | ), 223 | ($pos - length($body_src)), 224 | ); 225 | 226 | $_COR_CURRENT_METHOD->set_body( $body ); 227 | 228 | Cor::Parser::ASTBuilder::set_end_location( $body, $pos ); 229 | Cor::Parser::ASTBuilder::set_end_location( 230 | $_COR_CURRENT_METHOD, 231 | pos(), # XXX - need to use use just pos here, not sure why 232 | ); 233 | }) 234 | | 235 | # TODO: 236 | # make this track location information as well 237 | (?{ 238 | die 'unable to parse method body for `'.$_COR_CURRENT_METHOD->name.'` in class `'.$_COR_CURRENT_META->name.'`'; 239 | }) 240 | ) (?{ $_COR_CURRENT_META->add_method( $_COR_CURRENT_METHOD ); }) 241 | ) 242 | 243 | # --------------------------------------- 244 | # CONSTANTS 245 | # --------------------------------------- 246 | 247 | (? 248 | ( 249 | (const) (?{ 250 | $_COR_CURRENT_CONST = Cor::Parser::ASTBuilder::new_constant_at( 251 | pos() - length($^N) 252 | ); 253 | }) 254 | (?&PerlNWS) 255 | ((?&PerlQualifiedIdentifier)) (?{ 256 | $_COR_CURRENT_CONST->set_name( $^N ); 257 | }) 258 | (?&PerlOWS) 259 | (\=) 260 | (?&PerlOWS) 261 | ((?&PerlExpression)) (?{ 262 | $_COR_CURRENT_CONST->set_value( $^N ); 263 | }) 264 | (?&PerlOWS) 265 | (\;) (?{ 266 | Cor::Parser::ASTBuilder::set_end_location( 267 | $_COR_CURRENT_CONST, 268 | pos() - length($^N), 269 | ); 270 | 271 | $_COR_CURRENT_META->add_constant( $_COR_CURRENT_CONST ); 272 | }) 273 | ) 274 | ) 275 | 276 | 277 | (? 278 | ( 279 | (?> 280 | module 281 | (?&PerlNWS) 282 | ((?&PerlQualifiedIdentifier)) (?{ 283 | my $module_name = $^N; 284 | $_COR_CURRENT_MODULE = Cor::Parser::ASTBuilder::new_module_at( 285 | pos() - length($module_name) 286 | ); 287 | $_COR_CURRENT_MODULE->set_name( $module_name ); 288 | }) 289 | \; 290 | ) 291 | ) 292 | ) 293 | 294 | 295 | # --------------------------------------- 296 | # CLASS/ROLE 297 | # --------------------------------------- 298 | 299 | (? # TODO: come up with a better name 300 | \{ 301 | ( 302 | (?&PerlOWS) 303 | ((?: 304 | (?> 305 | (?&PerlSlotDeclaration) 306 | | 307 | (?&PerlMethodDeclaration) 308 | | 309 | (?&PerlConstantDeclaration) 310 | | 311 | # TODO: 312 | # make these track location information as well 313 | (?&PerlVariableDeclaration) (?{ die 'my/state/our variables are not allowed inside class/role declarations' }) 314 | | 315 | (?&PerlSubroutineDeclaration) (?{ die 'Subroutines are not allowed inside class/role declarations' }) 316 | | 317 | (?&PerlUseStatement) (?{ die 'use statements are not allowed inside class/role declarations' }) 318 | ) 319 | (?&PerlOWS) 320 | )*+) 321 | (?&PerlOWS) 322 | ) 323 | \} 324 | ) 325 | 326 | (? 327 | ((?&PerlQualifiedIdentifier)) (?{ $_COR_CURRENT_META->set_name( $^N ); }) 328 | (?: 329 | (?>(?&PerlNWS)) ((?&PerlVersionNumber)) (?{ $_COR_CURRENT_META->set_version( $^N ); }) 330 | )?+ 331 | ) 332 | 333 | (? 334 | ((?&PerlQualifiedIdentifier)) (?{ 335 | $_COR_CURRENT_REFERENCE = Cor::Parser::ASTBuilder::new_reference_at( pos() - length($^N) ); 336 | $_COR_CURRENT_REFERENCE->set_name( $^N ); 337 | }) 338 | (?: 339 | (?>(?&PerlNWS)) ((?&PerlVersionNumber)) (?{ $_COR_CURRENT_REFERENCE->set_version( $^N ); }) 340 | )?+ 341 | (?{ 342 | Cor::Parser::ASTBuilder::set_end_location( 343 | $_COR_CURRENT_REFERENCE, 344 | pos(), # XXX - need to use use just pos here, not sure why 345 | ); 346 | 347 | if ( $_COR_CURRENT_MODULE ) { 348 | $_COR_CURRENT_REFERENCE->set_module( $_COR_CURRENT_MODULE ); 349 | } 350 | }) 351 | ) 352 | 353 | (? 354 | (?: 355 | isa 356 | (?&PerlNWS) 357 | (?&PerlClassRoleReference) (?{ $_COR_CURRENT_META->add_superclass( $_COR_CURRENT_REFERENCE ) }) 358 | (?: 359 | (?>\, (?&PerlOWS)) 360 | (?&PerlClassRoleReference) (?{ $_COR_CURRENT_META->add_superclass( $_COR_CURRENT_REFERENCE ) }) 361 | )*+ 362 | (?&PerlOWS) 363 | )*+ 364 | ) 365 | 366 | (? 367 | (?: 368 | does 369 | (?&PerlNWS) 370 | (?&PerlClassRoleReference) (?{ $_COR_CURRENT_META->add_role( $_COR_CURRENT_REFERENCE ) }) 371 | (?: 372 | (?>\, (?&PerlOWS)) 373 | (?&PerlClassRoleReference) (?{ $_COR_CURRENT_META->add_role( $_COR_CURRENT_REFERENCE ) }) 374 | )*+ 375 | (?&PerlOWS) 376 | )*+ 377 | ) 378 | 379 | (? 380 | ( 381 | (class) (?{ 382 | $_COR_CURRENT_META = Cor::Parser::ASTBuilder::new_class_at( 383 | pos() - length($^N) 384 | ); 385 | }) 386 | (?&PerlNWS) 387 | (?&PerlClassRoleIdentifier) 388 | (?&PerlOWS) 389 | (?&PerlSubclassing) 390 | (?&PerlRoleConsumption) 391 | ( 392 | (?&PerlClassRoleBlock) (?{ 393 | Cor::Parser::ASTBuilder::set_end_location( 394 | $_COR_CURRENT_META, 395 | pos() 396 | ); 397 | if ( $_COR_CURRENT_MODULE ) { 398 | $_COR_CURRENT_META->set_module( $_COR_CURRENT_MODULE ); 399 | } 400 | }) 401 | ) 402 | ) 403 | ) 404 | 405 | (? 406 | ( 407 | (role) (?{ 408 | $_COR_CURRENT_META = Cor::Parser::ASTBuilder::new_role_at( 409 | pos() - length($^N) 410 | ); 411 | }) 412 | (?&PerlNWS) 413 | (?&PerlClassRoleIdentifier) 414 | (?&PerlOWS) 415 | (?&PerlRoleConsumption) 416 | ( 417 | (?&PerlClassRoleBlock) (?{ 418 | Cor::Parser::ASTBuilder::set_end_location( 419 | $_COR_CURRENT_META, 420 | pos() 421 | ); 422 | if ( $_COR_CURRENT_MODULE ) { 423 | $_COR_CURRENT_META->set_module( $_COR_CURRENT_MODULE ); 424 | } 425 | }) 426 | ) 427 | ) 428 | ) 429 | 430 | # --------------------------------------- 431 | # REDEFINED FROM PPR 432 | # --------------------------------------- 433 | 434 | (? 435 | \$\$ 436 | (?! [\$\{\w] ) 437 | | 438 | (?: 439 | \$ 440 | (?: 441 | [#] 442 | (?= (?> [\$^\w\{:+] | - (?! > ) ) ) 443 | )?+ 444 | (?&PerlOWS) 445 | )++ 446 | (?> 447 | \d++ 448 | | 449 | \^ [][A-Z^_?\\] 450 | | 451 | \{ \^ [A-Z_] \w*+ \} 452 | ## << start twigil handling 453 | | 454 | \! (?&PerlIdentifier) ## twigil with a ! 455 | | 456 | \. (?&PerlIdentifier) ## twigil with a . 457 | ## >> end twigil handling 458 | | 459 | (?>(?&PerlOldQualifiedIdentifier)) (?: :: )?+ 460 | | 461 | :: (?&PerlBlock) 462 | | 463 | [][!"#\$%&'()*+,.\\/:;<=>?\@\^`|~-] 464 | | 465 | \{ [!"#\$%&'()*+,.\\/:;<=>?\@\^`|~-] \} 466 | | 467 | \{ \w++ \} 468 | | 469 | (?&PerlBlock) 470 | ) 471 | | 472 | \$\# 473 | ) # End of rule 474 | 475 | ) 476 | 477 | $PPR::GRAMMAR 478 | }x; 479 | 480 | $COR_GRAMMAR = qr{ 481 | 482 | (?: 483 | ((?&PerlUseStatement)) (?{ push @_COR_USE_STATEMENTS => $^N; }) 484 | )?+ 485 | 486 | (?: (?&PerlModuleDeclaration) )? 487 | 488 | (?> (?&PerlRole) | (?&PerlClass) ) 489 | 490 | # TODO: 491 | # - capture complete POD document 492 | # - must start with =pod and end with =cut 493 | # - store it in package global for latter use 494 | # - prohibit __END__ tokens (maybe?) 495 | # - prohibit __DATA__ segements 496 | 497 | $COR_RULES 498 | }x; 499 | } 500 | 501 | sub parse ($source) { 502 | 503 | # localize all the globals ... 504 | 505 | local @_COR_USE_STATEMENTS; 506 | local $_COR_CURRENT_MODULE; 507 | local $_COR_CURRENT_META; 508 | local $_COR_CURRENT_REFERENCE; 509 | local $_COR_CURRENT_CONST; 510 | local $_COR_CURRENT_SLOT; 511 | local $_COR_CURRENT_METHOD; 512 | 513 | my $source_length = length($source); 514 | 515 | my @matches; 516 | 517 | while ( $source =~ /$COR_GRAMMAR/gx ) { 518 | 519 | # TODO: improve error handling here - SL 520 | if ( $PPR::ERROR ) { 521 | warn $PPR::ERROR->diagnostics; 522 | } 523 | 524 | push @matches => $_COR_CURRENT_META; 525 | } 526 | 527 | my $doc = Cor::Parser::ASTBuilder::new_document( 528 | use_statements => [ @_COR_USE_STATEMENTS ], 529 | asts => [ @matches ], 530 | ); 531 | 532 | 533 | Cor::Parser::ASTBuilder::set_end_location( 534 | $doc, 535 | $source_length, 536 | ); 537 | 538 | return $doc; 539 | } 540 | 541 | # ... 542 | 543 | sub _parse_method_body ($source, $meta) { 544 | 545 | # find all the class usage 546 | 547 | my (@class_usage, $class_usage_match, $class_usage_pos); 548 | 549 | # FIXME: 550 | # this is not ideal, it basically looks for things that 551 | # perform method calls, if it finds a scalar, then it 552 | # ignores it, but if it finds a bareword then it will 553 | # assume that it is some kind of class reference. 554 | # This can be improved a LOT! 555 | while ( $source =~ / 556 | (?> 557 | (?&PerlVariableScalar) 558 | | 559 | ((?&PerlQualifiedIdentifier)) (?{ $class_usage_match = $^N; $class_usage_pos = pos(); }) 560 | ) 561 | (?&PerlOWS) 562 | (?> \-\>) 563 | $COR_RULES/gx ) { 564 | 565 | # TODO: improve error handling here - SL 566 | if ( $PPR::ERROR ) { 567 | warn $PPR::ERROR->diagnostics; 568 | } 569 | 570 | next unless $class_usage_match; 571 | 572 | push @class_usage => { 573 | match => "$class_usage_match", 574 | start => ($class_usage_pos - length( $class_usage_match )) 575 | }; 576 | 577 | ($class_usage_match, $class_usage_pos) = (undef, undef); 578 | } 579 | 580 | # find all the method calls on $self 581 | 582 | my (@self_call_matches, $self_call_match, $self_call_pos); 583 | 584 | # FIXME: 585 | # this is not ideal, it assumes that $self 586 | # is available, and this may not always be 587 | # the case, so I think we need to make some 588 | # kind of other arragements. 589 | while ( $source =~ /\$self\-\>((?&PerlQualifiedIdentifier)) (?{ $self_call_match = $^N; $self_call_pos = pos(); }) $COR_RULES/gx ) { 590 | 591 | # TODO: improve error handling here - SL 592 | if ( $PPR::ERROR ) { 593 | warn $PPR::ERROR->diagnostics; 594 | } 595 | 596 | # NOTE: 597 | # doing static analysis on this would not 598 | # be as easy since there can be method 599 | # calls from the superclass, so this would 600 | # require some degree of class MRO traversal 601 | # in order to determine if the method call 602 | # is valid. For now we just catch the ones 603 | # that we know we have as locally defined 604 | # methods. So in this case we just capture 605 | # all of them and let the compiler sort it 606 | # out when generating the code. 607 | 608 | push @self_call_matches => { 609 | match => "$self_call_match", 610 | start => ($self_call_pos - length( $self_call_match )) 611 | }; 612 | 613 | ($self_call_match, $self_call_pos) = (undef, undef); 614 | } 615 | 616 | # find all slot accesses 617 | 618 | my (@slot_matches, $slot_match, $slot_pos); 619 | 620 | while ( $source =~ /((?&PerlVariableScalar)) (?{ $slot_match = $^N; $slot_pos = pos(); }) $COR_RULES/gx ) { 621 | 622 | # TODO: improve error handling here - SL 623 | if ( $PPR::ERROR ) { 624 | warn $PPR::ERROR->diagnostics; 625 | } 626 | 627 | 628 | # TODO: 629 | # this could be used to perform static 630 | # anaylsis and explode a compile time 631 | # error if the slot is not defined in 632 | # the same class 633 | next unless $meta->has_slot( $slot_match ); 634 | 635 | push @slot_matches => { 636 | match => "$slot_match", 637 | start => ($slot_pos - length( $slot_match )) 638 | }; 639 | 640 | ($slot_match, $slot_pos) = (undef, undef); 641 | } 642 | 643 | return ($source, \@slot_matches, \@self_call_matches, \@class_usage); 644 | } 645 | 646 | sub _parse_signature ($source) { 647 | 648 | my @matches; 649 | 650 | my $match; 651 | while ( $source =~ /((?&PerlVariable)) (?{ $match = $^N }) $COR_RULES/gx ) { 652 | 653 | # TODO: improve error handling here - SL 654 | if ( $PPR::ERROR ) { 655 | warn $PPR::ERROR->diagnostics; 656 | } 657 | 658 | push @matches => $match; 659 | } 660 | 661 | return ($source, \@matches); 662 | } 663 | 664 | sub _parse_attributes ($source) { 665 | 666 | my @matches; 667 | 668 | my ($match, $start, $end); 669 | while ( $source =~ 670 | / 671 | : 672 | (?>(?&PerlOWS)) 673 | (?>((?&PerlIdentifier)) (?{ 674 | $match = { name => $^N }; 675 | $start = pos() - length($match->{name}); 676 | })) 677 | (?: 678 | (?= \( ) ((?&PPR_quotelike_body)) (?{ 679 | $match->{args} = $^N; 680 | }) 681 | )?+ (?{ $end = pos(); }) 682 | 683 | $COR_RULES/gx 684 | ) { 685 | 686 | # TODO: improve error handling here - SL 687 | if ( $PPR::ERROR ) { 688 | warn $PPR::ERROR->diagnostics; 689 | } 690 | 691 | if ( $match->{args} ) { 692 | # clean off the whitespace & parens 693 | $match->{args} =~ s/^\(\s*//; 694 | $match->{args} =~ s/\s*\)$//; 695 | } 696 | 697 | push @matches => { 698 | match => $match, 699 | start => $start, 700 | end => $end, 701 | }; 702 | 703 | ($match, $start, $end) = (undef, undef, undef); 704 | } 705 | 706 | return ($source, \@matches); 707 | 708 | } 709 | 710 | 1; 711 | 712 | __END__ 713 | 714 | =pod 715 | 716 | =cut 717 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Attribute.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Attribute; 2 | # ABSTRACT: Cor AST for attributes attached to slots of methods 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation'; 11 | 12 | use slots ( 13 | name => sub {}, 14 | args => sub {}, 15 | ); 16 | 17 | sub name : ro; 18 | sub args : ro; 19 | 20 | sub set_name : wo; 21 | sub set_args : wo; 22 | 23 | sub has_name : predicate; 24 | sub has_args : predicate; 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =cut 33 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Class.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Class; 2 | # ABSTRACT: Cor AST for class declarations 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'Cor::Parser::AST::Role'; 10 | 11 | use slots ( 12 | superclasses => sub { [] }, 13 | ); 14 | 15 | sub superclasses : ro; 16 | 17 | sub add_superclass ($self, $superclass) { 18 | # TODO - test that $superclass is a Builder::Reference 19 | push $self->{superclasses}->@* => $superclass; 20 | } 21 | 22 | sub has_superclasses ($self) { !! $self->{superclasses}->@* } 23 | 24 | sub has_superclass ($self, $name) { !! scalar grep $_->name eq $name, $self->{methods}->@* } 25 | 26 | 27 | 1; 28 | 29 | __END__ 30 | 31 | =pod 32 | 33 | =cut 34 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Constant.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Constant; 2 | # ABSTRACT: Cor AST for constant declarations 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation'; 11 | 12 | use slots ( 13 | name => sub {}, 14 | value => sub {}, 15 | ); 16 | 17 | sub name : ro; 18 | sub value : ro; 19 | 20 | sub set_name : wo; 21 | sub set_value : wo; 22 | 23 | sub has_name : predicate; 24 | sub has_value : predicate; 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =cut 33 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Document.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Document; 2 | # ABSTRACT: Cor AST for an entire document 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation'; 11 | 12 | use slots ( 13 | use_statements => sub { +[] }, 14 | asts => sub { +[] }, 15 | ); 16 | 17 | sub use_statements : ro; 18 | sub asts : ro; 19 | 20 | sub set_use_statements : wo; 21 | sub set_asts : wo; 22 | 23 | sub has_use_statements : predicate; 24 | sub has_asts : predicate; 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =cut 33 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Location.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Location; 2 | # ABSTRACT: Cor AST source locations 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object::Immutable'; 10 | 11 | use slots ( 12 | char_at => sub { die 'A `char_at` is required' }, 13 | ); 14 | 15 | sub char_at : ro; 16 | 17 | 1; 18 | 19 | __END__ 20 | 21 | =pod 22 | 23 | =cut 24 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Method.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Method; 2 | # ABSTRACT: Cor AST for method declarations 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation', 11 | 'Cor::Parser::AST::Role::HasAttributes'; 12 | 13 | use slots ( 14 | name => sub {}, 15 | signature => sub {}, 16 | body => sub {}, 17 | is_abstract => sub {}, 18 | ); 19 | 20 | sub name : ro; 21 | sub signature : ro; 22 | sub body : ro; 23 | sub is_abstract : ro; 24 | 25 | sub set_name : wo; 26 | sub set_signature : wo; 27 | sub set_body : wo; 28 | sub set_is_abstract : wo; 29 | 30 | sub has_name : predicate; 31 | sub has_signature : predicate; 32 | sub has_body : predicate; 33 | sub has_is_abstract : predicate; 34 | 35 | 1; 36 | 37 | __END__ 38 | 39 | =pod 40 | 41 | =cut 42 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Method/Body.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Method::Body; 2 | # ABSTRACT: Cor AST for method body definitons 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation'; 11 | 12 | use slots ( 13 | slot_locations => sub { +[] }, 14 | self_call_locations => sub { +[] }, 15 | class_usage_locations => sub { +[] }, 16 | source => sub {}, 17 | ); 18 | 19 | sub slot_locations : ro; 20 | sub self_call_locations : ro; 21 | sub class_usage_locations : ro; 22 | sub source : ro; 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =cut 31 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Method/Signature.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Method::Signature; 2 | # ABSTRACT: Cor AST for method signatures 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation'; 11 | 12 | use slots ( 13 | arguments => sub { [] } 14 | ); 15 | 16 | sub arguments : ro; 17 | sub set_arguments : wo; 18 | sub has_arguments : predicate; 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =cut 27 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Module.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Module; 2 | # ABSTRACT: Cor AST for module declarations 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use List::Util; 10 | 11 | use parent 'UNIVERSAL::Object'; 12 | use roles 'Cor::Parser::AST::Role::HasLocation'; 13 | 14 | use slots ( 15 | name => sub {}, 16 | ); 17 | 18 | sub name : ro; 19 | sub set_name : wo; 20 | sub has_name : predicate; 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =cut 29 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Reference.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Reference; 2 | # ABSTRACT: Cor AST for referenced packages 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation'; 11 | 12 | use slots ( 13 | name => sub {}, 14 | version => sub {}, 15 | # internal 16 | _module => sub {}, 17 | ); 18 | 19 | sub name : ro; 20 | sub version : ro; 21 | sub module : ro(_); 22 | 23 | sub set_name : wo; 24 | sub set_version : wo; 25 | sub set_module : wo(_); 26 | 27 | sub has_name : predicate; 28 | sub has_version : predicate; 29 | sub has_module : predicate(_); 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =cut 38 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Role.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Role; 2 | # ABSTRACT: Cor AST for role declarations 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use List::Util; 10 | 11 | use parent 'UNIVERSAL::Object'; 12 | use roles 'Cor::Parser::AST::Role::HasLocation'; 13 | 14 | use slots ( 15 | name => sub { undef }, 16 | version => sub { undef }, 17 | module => sub { undef }, 18 | roles => sub { [] }, 19 | constants => sub { [] }, 20 | slots => sub { [] }, 21 | methods => sub { [] }, 22 | ); 23 | 24 | sub name : ro; 25 | sub version : ro; 26 | sub module : ro; 27 | sub roles : ro; 28 | sub constants : ro; 29 | sub slots : ro; 30 | sub methods : ro; 31 | 32 | sub set_name : wo; 33 | sub set_version : wo; 34 | sub set_module : wo; 35 | 36 | sub add_role ($self, $role) { 37 | # TODO - test that $role is a Builder::Reference 38 | push $self->{roles}->@* => $role; 39 | } 40 | 41 | sub add_constant ($self, $constant) { 42 | # TODO - test that $constant is a Builder::Constant 43 | push $self->{constants}->@* => $constant; 44 | } 45 | 46 | sub add_slot ($self, $slot) { 47 | # TODO - test that $slot is a Builder::Slot 48 | push $self->{slots}->@* => $slot; 49 | } 50 | 51 | sub add_method ($self, $method) { 52 | # TODO - test that $method is a Builder::Method 53 | push $self->{methods}->@* => $method; 54 | } 55 | 56 | sub has_name : predicate; 57 | sub has_version : predicate; 58 | sub has_module : predicate; 59 | sub has_roles ($self) { !! $self->{roles}->@* } 60 | sub has_constants ($self) { !! $self->{constants}->@* } 61 | sub has_slots ($self) { !! $self->{slots}->@* } 62 | sub has_methods ($self) { !! $self->{methods}->@* } 63 | 64 | # ... 65 | 66 | sub has_role ($self, $name) { !! scalar grep $_->name eq $name, $self->{roles}->@* } 67 | sub has_constant ($self, $name) { !! scalar grep $_->name eq $name, $self->{constants}->@* } 68 | sub has_slot ($self, $name) { !! scalar grep $_->name eq $name, $self->{slots}->@* } 69 | sub has_method ($self, $name) { !! scalar grep $_->name eq $name, $self->{methods}->@* } 70 | 71 | sub get_role ($self, $name) { List::Util::first { $_->name eq $name } $self->{roles}->@* } 72 | sub get_constant ($self, $name) { List::Util::first { $_->name eq $name } $self->{constants}->@* } 73 | sub get_slot ($self, $name) { List::Util::first { $_->name eq $name } $self->{slots}->@* } 74 | sub get_method ($self, $name) { List::Util::first { $_->name eq $name } $self->{methods}->@* } 75 | 76 | 1; 77 | 78 | __END__ 79 | 80 | =pod 81 | 82 | =cut 83 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Role/HasAttributes.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Role::HasAttributes; 2 | # ABSTRACT: Cor AST for AST entity which has attributes 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use slots ( 10 | attributes => sub { [] }, 11 | ); 12 | 13 | sub attributes : ro; 14 | sub set_attributes : wo; 15 | sub has_attributes ($self) { !! $self->{attributes}->@* } 16 | 17 | sub has_attribute ($self, $name) { 18 | !! scalar grep { $_->name eq $name } $self->{attributes}->@* 19 | } 20 | 21 | 1; 22 | 23 | __END__ 24 | 25 | =pod 26 | 27 | =cut 28 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Role/HasLocation.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Role::HasLocation; 2 | # ABSTRACT: Cor AST for AST entity which has a location 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | 10 | use slots ( 11 | start_location => sub {}, 12 | end_location => sub {}, 13 | ); 14 | 15 | sub start_location : ro; 16 | sub end_location : ro; 17 | 18 | sub set_start_location : wo; 19 | sub set_end_location : wo; 20 | 21 | sub has_start_location : predicate; 22 | sub has_end_location : predicate; 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =cut 31 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/Slot.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::Slot; 2 | # ABSTRACT: Cor AST for slot declarations 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation', 11 | 'Cor::Parser::AST::Role::HasAttributes'; 12 | 13 | use slots ( 14 | name => sub {}, 15 | type => sub {}, 16 | default => sub {}, 17 | ); 18 | 19 | sub identifier ($self) { 20 | $self->{name} =~ s/^\$[.!]?//r; 21 | } 22 | 23 | sub name : ro; 24 | sub type : ro; 25 | sub default : ro; 26 | 27 | sub set_name : wo; 28 | sub set_type : wo; 29 | sub set_default : wo; 30 | 31 | sub has_name : predicate; 32 | sub has_type : predicate; 33 | sub has_default : predicate; 34 | 35 | 1; 36 | 37 | __END__ 38 | 39 | =pod 40 | 41 | =cut 42 | -------------------------------------------------------------------------------- /lib/Cor/Parser/AST/TypeReference.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::AST::TypeReference; 2 | # ABSTRACT: Cor AST for type referenced packages 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures postderef ]; 7 | use decorators qw[ :accessors ]; 8 | 9 | use parent 'UNIVERSAL::Object'; 10 | use roles 'Cor::Parser::AST::Role::HasLocation'; 11 | 12 | use slots ( 13 | name => sub {}, 14 | ); 15 | 16 | sub name : ro; 17 | sub set_name : wo; 18 | sub has_name : predicate; 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =cut 27 | -------------------------------------------------------------------------------- /lib/Cor/Parser/ASTBuilder.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::ASTBuilder; 2 | # ABSTRACT: Cor AST builder 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures ]; 7 | 8 | use Cor::Parser::AST::Document; 9 | 10 | use Cor::Parser::AST::Module; 11 | 12 | use Cor::Parser::AST::Role; 13 | use Cor::Parser::AST::Class; 14 | 15 | use Cor::Parser::AST::Reference; 16 | use Cor::Parser::AST::TypeReference; 17 | 18 | use Cor::Parser::AST::Constant; 19 | use Cor::Parser::AST::Slot; 20 | use Cor::Parser::AST::Method; 21 | 22 | use Cor::Parser::AST::Method::Body; 23 | use Cor::Parser::AST::Method::Signature; 24 | 25 | use Cor::Parser::AST::Location; 26 | use Cor::Parser::AST::Attribute; 27 | 28 | sub new_document ( %args ) { 29 | Cor::Parser::AST::Document->new( 30 | %args, 31 | start_location => new_location_at( 0 ) 32 | ); 33 | } 34 | 35 | sub new_location_at ($char_at) { 36 | Cor::Parser::AST::Location->new( char_at => $char_at ) 37 | } 38 | 39 | sub new_module_at { Cor::Parser::AST::Module->new( start_location => new_location_at( @_ ) ) } 40 | sub new_role_at { Cor::Parser::AST::Role->new( start_location => new_location_at( @_ ) ) } 41 | sub new_class_at { Cor::Parser::AST::Class->new( start_location => new_location_at( @_ ) ) } 42 | sub new_reference_at { Cor::Parser::AST::Reference->new( start_location => new_location_at( @_ ) ) } 43 | sub new_constant_at { Cor::Parser::AST::Constant->new( start_location => new_location_at( @_ ) ) } 44 | sub new_slot_at { Cor::Parser::AST::Slot->new( start_location => new_location_at( @_ ) ) } 45 | sub new_method_at { Cor::Parser::AST::Method->new( start_location => new_location_at( @_ ) ) } 46 | 47 | sub new_method_body_at ( $source, $slot_matches, $self_call_matches, $class_usage_matches, $char_at ) { 48 | Cor::Parser::AST::Method::Body->new( 49 | source => $source, 50 | slot_locations => $slot_matches, 51 | self_call_locations => $self_call_matches, 52 | class_usage_locations => $class_usage_matches, 53 | start_location => new_location_at( $char_at ), 54 | ) 55 | } 56 | 57 | sub create_method_body ( $source ) { 58 | Cor::Parser::AST::Method::Body->new( source => $source ) 59 | } 60 | 61 | sub create_method_signature ( $arguments ) { 62 | Cor::Parser::AST::Method::Signature->new( arguments => $arguments ); 63 | } 64 | 65 | sub new_attributes_at ( $source, $attributes, $char_at ) { 66 | # NOTE: 67 | # ignore $source for now, we might want it later 68 | map { 69 | Cor::Parser::AST::Attribute->new( 70 | name => $_->{match}->{name}, 71 | args => $_->{match}->{args}, 72 | start_location => new_location_at( $char_at + $_->{start} ), 73 | end_location => new_location_at( $char_at + $_->{end} ), 74 | ) 75 | } $attributes->@* 76 | } 77 | 78 | sub new_signature_at ( $source, $arguments, $char_at ) { 79 | Cor::Parser::AST::Method::Signature->new( 80 | arguments => $arguments, 81 | start_location => new_location_at( $char_at ), 82 | end_location => new_location_at( $char_at + length( $source ) ), 83 | ); 84 | } 85 | 86 | sub new_type_reference ( $source, $name, $char_at ) { 87 | Cor::Parser::AST::TypeReference->new( 88 | name => $name, 89 | start_location => new_location_at( $char_at ), 90 | end_location => new_location_at( $char_at + length( $source ) ), 91 | ) 92 | } 93 | 94 | sub set_end_location ($ast, $char_at) { 95 | $ast->set_end_location( new_location_at( $char_at ) ); 96 | } 97 | 98 | 1; 99 | 100 | __END__ 101 | 102 | =pod 103 | 104 | =cut 105 | -------------------------------------------------------------------------------- /lib/Cor/Parser/ASTDumper.pm: -------------------------------------------------------------------------------- 1 | package Cor::Parser::ASTDumper; 2 | # ABSTRACT: Cor AST dumper 3 | 4 | use v5.24; 5 | use warnings; 6 | use experimental qw[ signatures ]; 7 | 8 | use roles (); 9 | use Scalar::Util (); 10 | 11 | sub dump_AST ($ast) { 12 | 13 | my %copy = %$ast; # fuck encapsulation 14 | 15 | foreach my $k ( keys %copy ) { 16 | # warn "looking at $k ( ", ($copy{ $k } // 'undef'), " ) \n"; 17 | if ( $k =~ /^_/ ) { # allow for private fields to be defined ... 18 | delete $copy{ $k }; 19 | } 20 | elsif ( not defined $copy{ $k } ) { 21 | # prune the output of 22 | # irrelvant output 23 | delete $copy{ $k }; 24 | #if ( exists $copy{ $k } ) { 25 | # warn "WTF this ($k) should be deleted!!\n"; 26 | #} 27 | } 28 | elsif ( Scalar::Util::blessed( $copy{ $k } ) && ! $copy{ $k }->roles::DOES('Cor::Parser::AST::Role::HasLocation') ) { 29 | delete $copy{ $k }; 30 | } 31 | elsif ( ref $copy{ $k } eq 'ARRAY' ) { 32 | if ( $copy{ $k }->@* ) { 33 | # dump recursively 34 | $copy{ $k } = [ map { 35 | #warn "looking at @ $_ (\$copy{ $k }) \n"; 36 | if ( Scalar::Util::blessed( $_ ) ) { 37 | #warn "dumping array item"; 38 | dump_AST( $_ ); 39 | } 40 | else { 41 | $_; 42 | } 43 | } $copy{ $k }->@* ]; 44 | } 45 | else { 46 | # if the ARRAY is empty, don't copy it ... 47 | delete $copy{ $k }; 48 | } 49 | } 50 | elsif ( Scalar::Util::blessed( $copy{ $k } ) && $copy{ $k }->roles::DOES('Cor::Parser::AST::Role::HasLocation') ) { 51 | # dump recursively 52 | $copy{ $k } = dump_AST( $copy{ $k } ); 53 | } 54 | } 55 | return \%copy; 56 | } 57 | 58 | 59 | 1; 60 | 61 | __END__ 62 | 63 | =pod 64 | 65 | =cut 66 | -------------------------------------------------------------------------------- /t/000-load.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | use_ok('Cor'); 10 | } 11 | 12 | done_testing; 13 | -------------------------------------------------------------------------------- /t/001-basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | BEGIN { 12 | use_ok('Cor'); 13 | use_ok('Cor::Parser'); 14 | use_ok('Cor::Parser::ASTDumper'); 15 | } 16 | 17 | my $src = join '' => ; 18 | 19 | my $doc = Cor::Parser::parse( $src ); 20 | 21 | #warn Dumper $doc; 22 | 23 | eq_or_diff( 24 | $doc->use_statements, 25 | [ 26 | 'use v5.24;', 27 | 'use Scalar::Utils;', 28 | 'use List::Utils;', 29 | 'use Other::Module;', 30 | ], 31 | '... got the expected use statements' 32 | ); 33 | 34 | my ($dumpable, $point, $point_3d) = $doc->asts->@*; 35 | 36 | # role definition 37 | is($dumpable->start_location->char_at, 68, '... got the right start char number'); 38 | is($dumpable->end_location->char_at, 139, '... got the right end char number'); 39 | 40 | # method definition 41 | is($dumpable->methods->[0]->start_location->char_at, 125, '... got the right start char number'); 42 | is($dumpable->methods->[0]->end_location->char_at, 136, '... got the right end char number'); 43 | 44 | eq_or_diff( 45 | Cor::Parser::ASTDumper::dump_AST( $dumpable ), 46 | { 47 | name => 'Dumpable', 48 | version => 'v0.01', 49 | methods => [ { name => 'dump', is_abstract => 1 } ], 50 | }, 51 | '... the Dumpable role looks correct' 52 | ); 53 | 54 | # class definition 55 | is($point->start_location->char_at, 141, '... got the right start char number'); 56 | is($point->end_location->char_at, 325, '... got the right end char number'); 57 | 58 | # superclass declaration 59 | is($point->superclasses->[0]->start_location->char_at, 163, '... got the right start char number'); 60 | is($point->superclasses->[0]->end_location->char_at, 180, '... got the right end char number'); 61 | 62 | # role declaration 63 | is($point->roles->[0]->start_location->char_at, 186, '... got the right start char number'); 64 | is($point->roles->[0]->end_location->char_at, 194, '... got the right end char number'); 65 | 66 | is($point->slots->[0]->identifier, '_x', '... got the right identifier for the slot'); 67 | is($point->slots->[1]->identifier, '_y', '... got the right identifier for the slot'); 68 | 69 | # slot declarations 70 | is($point->slots->[0]->start_location->char_at, 202, '... got the right start char number'); 71 | is($point->slots->[0]->end_location->char_at, 213, '... got the right end char number'); 72 | is($point->slots->[1]->start_location->char_at, 219, '... got the right start char number'); 73 | is($point->slots->[1]->end_location->char_at, 230, '... got the right end char number'); 74 | 75 | # method declarations 76 | is($point->methods->[0]->start_location->char_at, 237, '... got the right start char number'); 77 | is($point->methods->[0]->end_location->char_at, 254, '... got the right end char number'); 78 | 79 | is($point->methods->[1]->start_location->char_at, 260, '... got the right start char number'); 80 | is($point->methods->[1]->end_location->char_at, 277, '... got the right end char number'); 81 | 82 | is($point->methods->[2]->start_location->char_at, 284, '... got the right start char number'); 83 | is($point->methods->[2]->end_location->char_at, 323, '... got the right end char number'); 84 | 85 | is($point->methods->[2]->body->start_location->char_at, 296, '... got the right start char number'); 86 | is($point->methods->[2]->body->end_location->char_at, 323, '... got the right end char number'); 87 | 88 | eq_or_diff( 89 | Cor::Parser::ASTDumper::dump_AST( $point ), 90 | { 91 | 'name' => 'Point', 92 | 'version' => 'v0.01', 93 | 'superclasses' => [ { 'name' => 'UNIVERSAL::Object' } ], 94 | 'roles' => [ { 'name' => 'Dumpable' } ], 95 | 'slots' => [ 96 | { 'name' => '$_x', 'default' => '0' }, 97 | { 'default' => '0', 'name' => '$_y' } 98 | ], 99 | 'methods' => [ 100 | { 101 | 'name' => 'x', 102 | 'attributes' => [ 103 | { 104 | name => 'ro', 105 | args => '$_x', 106 | } 107 | ], 108 | 'is_abstract' => 1, 109 | }, 110 | { 111 | 'name' => 'y', 112 | 'attributes' => [ 113 | { 114 | name => 'ro', 115 | args => '$_y', 116 | } 117 | ], 118 | 'is_abstract' => 1, 119 | }, 120 | { 121 | 'name' => 'dump', 122 | 'body' => { 123 | source => '{ +{ x => $_x, y => $_y } }', 124 | slot_locations => [ 125 | { match => '$_x', start => 10 }, 126 | { match => '$_y', start => 20 }, 127 | ] 128 | }, 129 | } 130 | ], 131 | }, 132 | '... Point class looks correct' 133 | ); 134 | 135 | # class declaration 136 | is($point_3d->start_location->char_at, 327, '... got the right start char number'); 137 | is($point_3d->end_location->char_at, 483, '... got the right end char number'); 138 | 139 | # superclass declaration 140 | is($point_3d->superclasses->[0]->start_location->char_at, 351, '... got the right start char number'); 141 | is($point_3d->superclasses->[0]->end_location->char_at, 356, '... got the right end char number'); 142 | 143 | is($point_3d->slots->[0]->identifier, '_z', '... got the right identifier for the slot'); 144 | 145 | # slot declarations 146 | is($point_3d->slots->[0]->start_location->char_at, 364, '... got the right start char number'); 147 | is($point_3d->slots->[0]->end_location->char_at, 375, '... got the right end char number'); 148 | 149 | # method declarations 150 | is($point_3d->methods->[0]->start_location->char_at, 382, '... got the right start char number'); 151 | is($point_3d->methods->[0]->end_location->char_at, 399, '... got the right end char number'); 152 | 153 | is($point_3d->methods->[1]->start_location->char_at, 406, '... got the right start char number'); 154 | is($point_3d->methods->[1]->end_location->char_at, 480, '... got the right end char number'); 155 | 156 | is($point_3d->methods->[1]->body->start_location->char_at, 426, '... got the right start char number'); 157 | is($point_3d->methods->[1]->body->end_location->char_at, 480, '... got the right end char number'); 158 | 159 | eq_or_diff( 160 | Cor::Parser::ASTDumper::dump_AST( $point_3d ), 161 | { 162 | 'name' => 'Point3D', 163 | 'version' => 'v0.01', 164 | 'superclasses' => [ { 'name' => 'Point' } ], 165 | 'slots' => [ { 'default' => '0', 'name' => '$_z' } ], 166 | 'methods' => [ 167 | { 168 | 'name' => 'z', 169 | 'attributes' => [ 170 | { 171 | name => 'ro', 172 | args => '$_z', 173 | } 174 | ], 175 | 'is_abstract' => 1, 176 | 177 | }, 178 | { 179 | 'name' => 'dump', 180 | 'signature' => { arguments => [ '$self' ] }, 181 | 'body' => { 182 | source => '{ 183 | +{ $self->next::method->%*, z => $_z } 184 | }', 185 | slot_locations => [ 186 | { match => '$_z', start => 43 } 187 | ], 188 | self_call_locations => [ 189 | { match => 'next::method', start => 20 } 190 | ], 191 | class_usage_locations => [ 192 | { match => 'next::method', start => 20 } 193 | ], 194 | } 195 | } 196 | ], 197 | }, 198 | '... Point3D class looks correct' 199 | ); 200 | 201 | done_testing; 202 | 203 | __DATA__ 204 | 205 | use v5.24; 206 | use Scalar::Utils; 207 | use List::Utils; 208 | use Other::Module; 209 | 210 | role Dumpable v0.01 { 211 | # can include comments ... 212 | method dump; 213 | } 214 | 215 | class Point v0.01 isa UNIVERSAL::Object does Dumpable { 216 | 217 | has $_x = 0; 218 | has $_y = 0; 219 | 220 | method x :ro($_x); 221 | method y :ro($_y); 222 | 223 | method dump { +{ x => $_x, y => $_y } } 224 | } 225 | 226 | class Point3D v0.01 isa Point { 227 | 228 | has $_z = 0; 229 | 230 | method z :ro($_z); 231 | 232 | method dump ($self) { 233 | +{ $self->next::method->%*, z => $_z } 234 | } 235 | 236 | } 237 | -------------------------------------------------------------------------------- /t/002-basic-dump.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | BEGIN { 12 | use_ok('Cor'); 13 | use_ok('Cor::Parser'); 14 | use_ok('Cor::Parser::ASTDumper'); 15 | } 16 | 17 | my $src = join '' => ; 18 | 19 | my $doc = Cor::Parser::parse( $src ); 20 | 21 | eq_or_diff( 22 | $doc->use_statements, 23 | [ 24 | 'use v5.24;', 25 | 'use Scalar::Utils;', 26 | 'use List::Utils;', 27 | 'use Other::Module;', 28 | ], 29 | '... got the expected use statements' 30 | ); 31 | 32 | my ($dumpable, $plane, $point, $point_3d) = $doc->asts->@*; 33 | 34 | eq_or_diff( 35 | Cor::Parser::ASTDumper::dump_AST( $dumpable ), 36 | { 37 | name => 'Dumpable', 38 | version => 'v0.01', 39 | methods => [ { name => 'dump', is_abstract => 1 } ], 40 | }, 41 | '... the Dumpable role looks correct' 42 | ); 43 | 44 | eq_or_diff( 45 | Cor::Parser::ASTDumper::dump_AST( $plane ), 46 | { 47 | 'name' => 'Plane', 48 | 'version' => 'v0.01', 49 | 'module' => { 'name' => 'Geometry' }, 50 | 'superclasses' => [ { 'name' => 'UNIVERSAL::Object' } ], 51 | 'slots' => [ 52 | { 53 | 'name' => '$_space', 54 | 'type' => { name => 'ArrayRef[ ArrayRef[Point] ]' }, 55 | }, 56 | ] 57 | }, 58 | '... Plane class looks correct' 59 | ); 60 | 61 | eq_or_diff( 62 | Cor::Parser::ASTDumper::dump_AST( $point ), 63 | { 64 | 'name' => 'Point', 65 | 'version' => 'v0.01', 66 | 'module' => { 'name' => 'Geometry' }, 67 | 'superclasses' => [ { 'name' => 'UNIVERSAL::Object' } ], 68 | 'roles' => [ { 'name' => 'Dumpable' } ], 69 | 'constants' => [ { name => 'DEBUG', value => '$ENV{POINT_DEBUG} // 0' } ], 70 | 'slots' => [ 71 | { 72 | 'name' => '$_x', 73 | 'attributes' => [ { name => 'optional' } ], 74 | 'default' => '0', 75 | 'type' => { name => 'Int' }, 76 | }, 77 | { 78 | 'name' => '$_y', 79 | 'attributes' => [ { name => 'optional' } ], 80 | 'default' => '0', 81 | 'type' => { name => 'Int' }, 82 | }, 83 | ], 84 | 'methods' => [ 85 | { 86 | 'name' => 'x', 87 | 'attributes' => [ 88 | { 89 | name => 'ro', 90 | args => '$_x', 91 | } 92 | ], 93 | 'is_abstract' => 1, 94 | }, 95 | { 96 | 'name' => 'y', 97 | 'attributes' => [ 98 | { 99 | name => 'ro', 100 | args => '$_y', 101 | } 102 | ], 103 | 'is_abstract' => 1, 104 | }, 105 | { 106 | 'name' => 'dump', 107 | 'body' => { 108 | source => '{ +{ x => $_x, y => $_y } }', 109 | slot_locations => [ 110 | { match => '$_x', start => 10 }, 111 | { match => '$_y', start => 20 }, 112 | ] 113 | }, 114 | } 115 | ], 116 | }, 117 | '... Point class looks correct' 118 | ); 119 | 120 | eq_or_diff( 121 | Cor::Parser::ASTDumper::dump_AST( $point_3d ), 122 | { 123 | 'name' => 'Point3D', 124 | 'version' => 'v0.01', 125 | 'module' => { 'name' => 'Geometry' }, 126 | 'superclasses' => [ { 'name' => 'Point' } ], 127 | 'slots' => [ 128 | { 129 | 'name' => '$_z', 130 | 'attributes' => [ { name => 'optional' } ], 131 | 'default' => '0', 132 | 'type' => { name => 'Int' }, 133 | }, 134 | ], 135 | 'methods' => [ 136 | { 137 | 'name' => 'z', 138 | 'attributes' => [ 139 | { 140 | name => 'ro', 141 | args => '$_z', 142 | } 143 | ], 144 | 'is_abstract' => 1, 145 | 146 | }, 147 | { 148 | 'name' => 'dump', 149 | 'signature' => { arguments => [ '$self' ] }, 150 | 'body' => { 151 | source => '{ 152 | +{ $self->next::method->%*, z => $_z } 153 | }', 154 | slot_locations => [ 155 | { match => '$_z', start => 43 } 156 | ], 157 | self_call_locations => [ 158 | { match => 'next::method', start => 20 } 159 | ], 160 | class_usage_locations => [ 161 | { match => 'next::method', start => 20 } 162 | ], 163 | } 164 | } 165 | ], 166 | }, 167 | '... Point3D class looks correct' 168 | ); 169 | 170 | done_testing; 171 | 172 | __DATA__ 173 | 174 | use v5.24; 175 | use Scalar::Utils; 176 | 177 | role Dumpable v0.01 { 178 | # can include comments ... 179 | method dump; 180 | } 181 | 182 | module Geometry; 183 | 184 | use List::Utils; 185 | 186 | class Plane v0.01 isa UNIVERSAL::Object { 187 | 188 | has ArrayRef[ ArrayRef[Point] ] $_space; 189 | 190 | } 191 | 192 | class Point v0.01 isa UNIVERSAL::Object does Dumpable { 193 | 194 | const DEBUG = $ENV{POINT_DEBUG} // 0; 195 | 196 | has Int $_x :optional = 0; 197 | has Int $_y :optional = 0; 198 | 199 | method x :ro($_x); 200 | method y :ro($_y); 201 | 202 | method dump { +{ x => $_x, y => $_y } } 203 | } 204 | 205 | use Other::Module; 206 | 207 | class Point3D v0.01 isa Point { 208 | 209 | has Int $_z :optional = 0; 210 | 211 | method z :ro($_z); 212 | 213 | method dump ($self) { 214 | +{ $self->next::method->%*, z => $_z } 215 | } 216 | 217 | } 218 | -------------------------------------------------------------------------------- /t/010-compiler.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ signatures postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | BEGIN { 12 | use_ok('Cor'); 13 | use_ok('Cor::Evaluator'); 14 | } 15 | 16 | 17 | my $GOT; 18 | subtest '... verify the AST object' => sub { 19 | 20 | my $original = join '' => ; 21 | my $doc = Cor::Parser::parse( $original ); 22 | 23 | #warn Dumper $doc; 24 | 25 | my $compiler = Cor::Compiler->new( doc => $doc ); 26 | 27 | $GOT = $compiler->compile; 28 | 29 | my ($ast) = $doc->asts->@*; 30 | isa_ok($ast, 'Cor::Parser::AST::Class'); 31 | is($ast->name, 'Point', '... the AST is for the Point class'); 32 | }; 33 | 34 | my $EXPECTED = 'use Scalar::Util; 35 | package Geometry::Point 0.01 { 36 | use v5.24; 37 | use warnings; 38 | use experimental qw[ signatures ]; 39 | use MOP; 40 | use roles (); 41 | use UNIVERSAL::Object; 42 | # superclasses 43 | our @ISA; BEGIN { @ISA = qw[UNIVERSAL::Object] } 44 | # constructor 45 | sub BUILDARGS ($class, %args) { 46 | my %proto; 47 | $proto{q[$x]} = $args{q[x]} if exists $args{q[x]}; 48 | $proto{q[$y]} = $args{q[y]} if exists $args{q[y]}; 49 | return \%proto; 50 | } 51 | # constants 52 | use constant DEBUG => ($ENV{DEBUG} // 0); 53 | # slots 54 | our %HAS; BEGIN { %HAS = ( 55 | q[$x] => sub { 0 }, 56 | q[$y] => sub { 0 }, 57 | ) } 58 | # methods 59 | sub x ($self) { $self->{q[$x]} } 60 | sub y ($self) { $self->{q[$y]} } 61 | sub dump ($self) { 62 | return +{ x => $self->{q[$x]}, y => $self->{q[$y]} }; 63 | } 64 | 1; 65 | }'; 66 | 67 | eq_or_diff($GOT, $EXPECTED, '... simple compiler working'); 68 | 69 | subtest '... eval and test the compiled output', sub { 70 | 71 | Cor::Evaluator::evaluate( $GOT ); 72 | 73 | my $p = Geometry::Point->new( x => 10, y => 20 ); 74 | isa_ok($p, 'Geometry::Point'); 75 | 76 | is($p->x, 10, '... got the right value for x'); 77 | is($p->y, 20, '... got the right value for y'); 78 | 79 | is_deeply($p->dump, { x => 10, y => 20 }, '... got the right value from dump method'); 80 | }; 81 | 82 | done_testing; 83 | 84 | __DATA__ 85 | 86 | use Scalar::Util; 87 | 88 | module Geometry; 89 | 90 | class Point v0.01 { 91 | 92 | const DEBUG = $ENV{DEBUG} // 0; 93 | 94 | has $x = 0; 95 | has $y = 0; 96 | 97 | method x :ro($x); 98 | method y :ro($y); 99 | 100 | method dump { 101 | return +{ x => $x, y => $y }; 102 | } 103 | } 104 | 105 | -------------------------------------------------------------------------------- /t/011-compiler-w-multiple-units.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | BEGIN { 12 | use_ok('Cor'); 13 | use_ok('Cor::Evaluator'); 14 | } 15 | 16 | 17 | my $GOT; 18 | subtest '... verify the AST object' => sub { 19 | 20 | my $original = join '' => ; 21 | my $doc = Cor::Parser::parse( $original ); 22 | 23 | { 24 | my $ast = $doc->asts->[0]; 25 | isa_ok($ast, 'Cor::Parser::AST::Role'); 26 | is($ast->name, 'Dumpable', '... the AST is for the Dumpable role'); 27 | } 28 | { 29 | my $ast = $doc->asts->[1]; 30 | isa_ok($ast, 'Cor::Parser::AST::Class'); 31 | is($ast->name, 'Point', '... the AST is for the Point class'); 32 | 33 | #warn Dumper $ast->dump; 34 | } 35 | { 36 | my $ast = $doc->asts->[2]; 37 | isa_ok($ast, 'Cor::Parser::AST::Class'); 38 | is($ast->name, 'Point3D', '... the AST is for the Point3D class'); 39 | } 40 | 41 | my $compiler = Cor::Compiler->new( 42 | doc => $doc, 43 | module_map => { 44 | Point => 'Geometry::Point', 45 | Point3D => 'Geometry::Point3D', 46 | } 47 | ); 48 | 49 | $GOT = $compiler->compile; 50 | 51 | #warn $GOT; 52 | }; 53 | 54 | subtest '... eval and test the compiled output', sub { 55 | 56 | Cor::Evaluator::evaluate( $GOT ); 57 | 58 | my $p = Geometry::Point3D->new( x => 10, y => 20, z => 5 ); 59 | isa_ok($p, 'Geometry::Point3D'); 60 | isa_ok($p, 'Geometry::Point'); 61 | 62 | ok(!$p->can('dump_x'), '... the object has no dump_x method'); 63 | ok(!$p->can('dump_y'), '... the object has no dump_y method'); 64 | 65 | is($p->x, 10, '... got the right value for x'); 66 | is($p->y, 20, '... got the right value for y'); 67 | is($p->z, 5, '... got the right value for z'); 68 | 69 | ok($p->has_x, '... has a value for x'); 70 | ok($p->has_y, '... has a value for y'); 71 | ok($p->has_z, '... has a value for z'); 72 | 73 | $p->set_x(undef); 74 | $p->set_y(undef); 75 | $p->set_z(undef); 76 | 77 | ok(!$p->has_x, '... has a value for x'); 78 | ok(!$p->has_y, '... has a value for y'); 79 | ok(!$p->has_z, '... has a value for z'); 80 | 81 | $p->set_x(100); 82 | $p->set_y(200); 83 | $p->set_z(50); 84 | 85 | is($p->x, 100, '... got the right value for x'); 86 | is($p->y, 200, '... got the right value for y'); 87 | is($p->z, 50, '... got the right value for z'); 88 | 89 | is_deeply($p->dump, { x => 100, y => 200, z => 50 }, '... got the right value from dump method'); 90 | }; 91 | 92 | done_testing; 93 | 94 | __DATA__ 95 | 96 | role Dumpable { 97 | # can include comments ... 98 | method dump; 99 | } 100 | 101 | module Geometry; 102 | 103 | class Point does Dumpable { 104 | 105 | has $x :reader :writer(set_x) :predicate = 0; 106 | has $y :reader :writer(set_y) :predicate = 0; 107 | 108 | method dump_x : private { 0+$x } 109 | method dump_y : private { 0+$y } 110 | 111 | method dump { +{ x => $self->dump_x(), y => $self->dump_y() } } 112 | 113 | method to_JSON { $self->dump() } 114 | } 115 | 116 | class Point3D isa Point { 117 | 118 | has $z :reader = 0; 119 | 120 | method set_z :writer($z); 121 | method has_z :predicate($z); 122 | 123 | method dump_z : private { 0+$z } 124 | 125 | method dump { 126 | +{ $self->next::method->%*, z => $self->dump_z() } 127 | } 128 | 129 | } 130 | -------------------------------------------------------------------------------- /t/015-compiler-errors.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ signatures postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Test::Fatal; 10 | use Data::Dumper; 11 | 12 | BEGIN { 13 | use_ok('Cor'); 14 | use_ok('Cor::Parser'); 15 | } 16 | 17 | subtest '... testing bad perl statements in method' => sub { 18 | like( 19 | exception { 20 | Cor::Parser::parse(q[ 21 | class Foo { 22 | method foo { 23 | .= $foo; 24 | 25 | return $foo; 26 | } 27 | } 28 | ]); 29 | }, 30 | qr/^unable to parse method body for `foo` in class `Foo`/, 31 | '... got the expected exception' 32 | ); 33 | }; 34 | 35 | subtest '... testing bad perl statements in slot default' => sub { 36 | like( 37 | exception { 38 | Cor::Parser::parse(q[ 39 | class Foo { 40 | 41 | has $foo = .$bar; 42 | 43 | } 44 | ]); 45 | }, 46 | qr/^unable to parse slot default for `\$foo` in class `Foo`/, 47 | '... got the expected exception' 48 | ); 49 | }; 50 | 51 | subtest '... testing use statements in class/role' => sub { 52 | like( 53 | exception { 54 | Cor::Parser::parse(q[ 55 | class Foo { 56 | use Scalar::Util; 57 | } 58 | ]); 59 | }, 60 | qr/^use statements are not allowed inside class\/role declarations/, 61 | '... got the expected exception' 62 | ); 63 | }; 64 | 65 | subtest '... testing variables in class/role' => sub { 66 | like( 67 | exception { 68 | Cor::Parser::parse(q[ 69 | class Foo { 70 | my $foo; 71 | } 72 | ]); 73 | }, 74 | qr/^my\/state\/our variables are not allowed inside class\/role declarations/, 75 | '... got the expected exception' 76 | ); 77 | 78 | like( 79 | exception { 80 | Cor::Parser::parse(q[ 81 | class Foo { 82 | state $foo; 83 | } 84 | ]); 85 | }, 86 | qr/^my\/state\/our variables are not allowed inside class\/role declarations/, 87 | '... got the expected exception' 88 | ); 89 | 90 | like( 91 | exception { 92 | Cor::Parser::parse(q[ 93 | class Foo { 94 | our $foo; 95 | } 96 | ]); 97 | }, 98 | qr/^my\/state\/our variables are not allowed inside class\/role declarations/, 99 | '... got the expected exception' 100 | ); 101 | }; 102 | 103 | subtest '... testing subroutines in class/role' => sub { 104 | like( 105 | exception { 106 | Cor::Parser::parse(q[ 107 | class Foo { 108 | sub bar {} 109 | } 110 | ]); 111 | }, 112 | qr/^Subroutines are not allowed inside class\/role declarations/, 113 | '... got the expected exception' 114 | ); 115 | }; 116 | 117 | done_testing; 118 | 119 | 120 | -------------------------------------------------------------------------------- /t/020-load-from-disk.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | use roles (); 12 | 13 | use lib './t/lib'; 14 | 15 | BEGIN { 16 | use_ok('Cor'); 17 | } 18 | 19 | my @pmc_files_to_delete; 20 | 21 | subtest '... compiles all the classes together properly' => sub { 22 | ok((push @pmc_files_to_delete => Cor::build( 'Currency::USD', recurse => 1 )), '... loaded the Currency::US class with Cor'); 23 | }; 24 | 25 | subtest '... does the compiled classes work together properly' => sub { 26 | 27 | require_ok('Currency::USD'); 28 | 29 | my $dollar = Currency::USD->new( amount => 10 ); 30 | ok($dollar->isa( 'Currency::USD' ), '... the dollar is a Currency::US instance'); 31 | ok($dollar->roles::DOES( 'Eq' ), '... the dollar does the Eq role'); 32 | ok($dollar->roles::DOES( 'Comparable' ), '... the dollar does the Comparable role'); 33 | ok($dollar->roles::DOES( 'Printable' ), '... the dollar does the Printable role'); 34 | 35 | can_ok($dollar, 'equal_to'); 36 | can_ok($dollar, 'not_equal_to'); 37 | 38 | can_ok($dollar, 'greater_than'); 39 | can_ok($dollar, 'greater_than_or_equal_to'); 40 | can_ok($dollar, 'less_than'); 41 | can_ok($dollar, 'less_than_or_equal_to'); 42 | 43 | can_ok($dollar, 'compare'); 44 | can_ok($dollar, 'to_string'); 45 | 46 | is($dollar->to_string, '$10.00 USD', '... got the right to_string value'); 47 | 48 | ok($dollar->equal_to( $dollar ), '... we are equal to ourselves'); 49 | ok(!$dollar->not_equal_to( $dollar ), '... we are not not equal to ourselves'); 50 | 51 | ok(Currency::USD->new( amount => 20 )->greater_than( $dollar ), '... 20 is greater than 10'); 52 | ok(!Currency::USD->new( amount => 2 )->greater_than( $dollar ), '... 2 is not greater than 10'); 53 | 54 | ok(!Currency::USD->new( amount => 10 )->greater_than( $dollar ), '... 10 is not greater than 10'); 55 | ok(Currency::USD->new( amount => 10 )->greater_than_or_equal_to( $dollar ), '... 10 is greater than or equal to 10'); 56 | 57 | }; 58 | 59 | foreach (@pmc_files_to_delete) { 60 | #diag "Deleting $_"; 61 | unlink $_; 62 | } 63 | 64 | done_testing; 65 | -------------------------------------------------------------------------------- /t/021-load-from-disk.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | use roles (); 12 | 13 | use lib './t/lib'; 14 | 15 | BEGIN { 16 | use_ok('Cor'); 17 | } 18 | 19 | my @pmc_files_to_delete; 20 | 21 | subtest '... compiles all the classes together properly' => sub { 22 | ok((push @pmc_files_to_delete => Cor::build_module( 'Collections' )), '... loaded the Collections module with Cor'); 23 | }; 24 | 25 | subtest '... does the compiled classes work together properly' => sub { 26 | 27 | require_ok('Collections::LinkedList'); 28 | require_ok('Collections::LinkedList::Node'); 29 | 30 | my $ll = Collections::LinkedList->new(); 31 | 32 | for(0..9) { 33 | $ll->append( 34 | Collections::LinkedList::Node->new(value => $_) 35 | ); 36 | } 37 | 38 | is($ll->head->get_value, 0, '... head is 0'); 39 | is($ll->tail->get_value, 9, '... tail is 9'); 40 | is($ll->count, 10, '... count is 10'); 41 | 42 | $ll->prepend(Collections::LinkedList::Node->new(value => -1)); 43 | is($ll->count, 11, '... count is now 11'); 44 | 45 | $ll->insert(5, Collections::LinkedList::Node->new(value => 11)); 46 | is($ll->count, 12, '... count is now 12'); 47 | 48 | my $node = $ll->remove(8); 49 | is($ll->count, 11, '... count is 11 again'); 50 | 51 | ok(!$node->get_next, '... detached node does not have a next'); 52 | ok(!$node->get_previous, '... detached node does not have a previous'); 53 | is($node->get_value, 6, '... detached node has the right value'); 54 | ok($node->isa('Collections::LinkedList::Node'), '... node is a Collections::LinkedList::Node'); 55 | 56 | eval { $ll->remove(99) }; 57 | like($@, qr/^Index \(99\) out of bounds/, '... removing out of range produced error'); 58 | eval { $ll->insert(-1, Collections::LinkedList::Node->new(value => 2)) }; 59 | like($@, qr/^Index \(-1\) out of bounds/, '... inserting out of range produced error'); 60 | 61 | is($ll->sum, 49, '... things sum correctly'); 62 | }; 63 | 64 | foreach (@pmc_files_to_delete) { 65 | #diag "Deleting $_"; 66 | unlink $_; 67 | } 68 | 69 | done_testing; 70 | -------------------------------------------------------------------------------- /t/022-load-from-disk.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | use roles (); 12 | 13 | use lib './t/lib'; 14 | 15 | BEGIN { 16 | use_ok('Cor'); 17 | } 18 | 19 | my @pmc_files_to_delete; 20 | 21 | subtest '... compiles all the classes together properly' => sub { 22 | ok((push @pmc_files_to_delete => Cor::build_module( 'Finance' )), '... loaded the Finance module with Cor'); 23 | }; 24 | 25 | subtest '... does the compiled classes work together properly' => sub { 26 | 27 | require_ok('Finance::BankAccount'); 28 | require_ok('Finance::CheckingAccount'); 29 | 30 | my $savings = Finance::BankAccount->new( balance => 250 ); 31 | isa_ok($savings, 'Finance::BankAccount' ); 32 | 33 | is($savings->balance, 250, '... got the savings balance we expected'); 34 | 35 | $savings->withdraw( 50 ); 36 | is($savings->balance, 200, '... got the savings balance we expected'); 37 | 38 | $savings->deposit( 150 ); 39 | is($savings->balance, 350, '... got the savings balance we expected'); 40 | 41 | my $checking = Finance::CheckingAccount->new( 42 | overdraft_account => $savings, 43 | ); 44 | isa_ok($checking, 'Finance::CheckingAccount'); 45 | isa_ok($checking, 'Finance::BankAccount'); 46 | 47 | ok(!$checking->can('withdraw_from_overdraft'), '... we do not have a `withdraw_from_overdraft` method available'); 48 | 49 | is($checking->balance, 0, '... got the checking balance we expected'); 50 | 51 | $checking->deposit( 100 ); 52 | is($checking->balance, 100, '... got the checking balance we expected'); 53 | is($checking->overdraft_account, $savings, '... got the right overdraft account'); 54 | 55 | $checking->withdraw( 50 ); 56 | is($checking->balance, 50, '... got the checking balance we expected'); 57 | is($savings->balance, 350, '... got the savings balance we expected'); 58 | 59 | $checking->withdraw( 200 ); 60 | is($checking->balance, 0, '... got the checking balance we expected'); 61 | is($savings->balance, 200, '... got the savings balance we expected'); 62 | 63 | }; 64 | 65 | foreach (@pmc_files_to_delete) { 66 | #diag "Deleting $_"; 67 | unlink $_; 68 | } 69 | 70 | done_testing; 71 | -------------------------------------------------------------------------------- /t/023-load-from-disk.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use v5.24; 4 | use warnings; 5 | use experimental qw[ postderef ]; 6 | 7 | use Test::More; 8 | use Test::Differences; 9 | use Data::Dumper; 10 | 11 | use roles (); 12 | 13 | use lib './t/lib'; 14 | 15 | BEGIN { 16 | use_ok('Cor'); 17 | } 18 | 19 | my @pmc_files_to_delete; 20 | 21 | subtest '... compiles all the classes together properly' => sub { 22 | ok((push @pmc_files_to_delete => Cor::build_module( 'Data' )), '... loaded the Data module with Cor'); 23 | }; 24 | 25 | subtest '... does the compiled classes work together properly' => sub { 26 | 27 | require_ok('Data::BinaryTree'); 28 | 29 | my $t = Data::BinaryTree->new; 30 | ok($t->isa('Data::BinaryTree'), '... this is a BinaryTree object'); 31 | 32 | ok(!$t->has_parent, '... this tree has no parent'); 33 | 34 | ok(!$t->has_left, '... left node has not been created yet'); 35 | ok(!$t->has_right, '... right node has not been created yet'); 36 | 37 | ok($t->left->isa('Data::BinaryTree'), '... left is a Data::BinaryTree object'); 38 | ok($t->right->isa('Data::BinaryTree'), '... right is a Data::BinaryTree object'); 39 | 40 | ok($t->has_left, '... left node has now been created'); 41 | ok($t->has_right, '... right node has now been created'); 42 | 43 | ok($t->left->has_parent, '... left has a parent'); 44 | is($t->left->parent, $t, '... and it is us'); 45 | 46 | ok($t->right->has_parent, '... right has a parent'); 47 | is($t->right->parent, $t, '... and it is us'); 48 | 49 | }; 50 | 51 | foreach (@pmc_files_to_delete) { 52 | #diag "Deleting $_"; 53 | unlink $_; 54 | } 55 | 56 | done_testing; 57 | -------------------------------------------------------------------------------- /t/lib/Collections/LinkedList.pm: -------------------------------------------------------------------------------- 1 | module Collections; 2 | 3 | class LinkedList { 4 | 5 | has $!head; 6 | has $!tail; 7 | has $!count = 0; 8 | 9 | method head : ro($!head); 10 | method tail : ro($!tail); 11 | method count : ro($!count); 12 | 13 | method append ($node) { 14 | unless($!tail) { 15 | $!tail = $node; 16 | $!head = $node; 17 | $!count++; 18 | return; 19 | } 20 | $!tail->set_next($node); 21 | $node->set_previous($!tail); 22 | $!tail = $node; 23 | $!count++; 24 | } 25 | 26 | method insert ($index, $node) { 27 | die "Index ($index) out of bounds" 28 | if $index < 0 or $index > $!count - 1; 29 | 30 | my $tmp = $!head; 31 | $tmp = $tmp->get_next while($index--); 32 | $node->set_previous($tmp->get_previous); 33 | $node->set_next($tmp); 34 | $tmp->get_previous->set_next($node); 35 | $tmp->set_previous($node); 36 | $!count++; 37 | } 38 | 39 | method remove ($index) { 40 | die "Index ($index) out of bounds" 41 | if $index < 0 or $index > $!count - 1; 42 | 43 | my $tmp = $!head; 44 | $tmp = $tmp->get_next while($index--); 45 | $tmp->get_previous->set_next($tmp->get_next); 46 | $tmp->get_next->set_previous($tmp->get_previous); 47 | $!count--; 48 | $tmp->detach(); 49 | } 50 | 51 | method prepend ($node) { 52 | unless($!head) { 53 | $!tail = $node; 54 | $!head = $node; 55 | $!count++; 56 | return; 57 | } 58 | $!head->set_previous($node); 59 | $node->set_next($!head); 60 | $!head = $node; 61 | $!count++; 62 | } 63 | 64 | method sum { 65 | my $sum = 0; 66 | my $tmp = $!head; 67 | do { $sum += $tmp->get_value } while($tmp = $tmp->get_next); 68 | return $sum; 69 | } 70 | } 71 | -------------------------------------------------------------------------------- /t/lib/Collections/LinkedList/Node.pm: -------------------------------------------------------------------------------- 1 | module Collections; 2 | 3 | class LinkedList::Node { 4 | 5 | has $.value; 6 | 7 | has $!previous; 8 | has $!next; 9 | 10 | method get_value : ro($.value); 11 | method set_value : wo($.value); 12 | 13 | method get_previous : ro($!previous); 14 | method set_previous : wo($!previous); 15 | 16 | method get_next : ro($!next); 17 | method set_next : wo($!next); 18 | 19 | method detach { 20 | ($!previous, $!next) = (undef) x 2; 21 | $self; 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /t/lib/Comparable.pm: -------------------------------------------------------------------------------- 1 | 2 | role Comparable does Eq { 3 | method compare; 4 | method equal_to ($other) { 5 | $self->compare($other) == 0; 6 | } 7 | 8 | method greater_than ($other) { 9 | $self->compare($other) == 1; 10 | } 11 | 12 | method less_than ($other) { 13 | $self->compare($other) == -1; 14 | } 15 | 16 | method greater_than_or_equal_to ($other) { 17 | $self->greater_than($other) || $self->equal_to($other); 18 | } 19 | 20 | method less_than_or_equal_to ($other) { 21 | $self->less_than($other) || $self->equal_to($other); 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /t/lib/Currency/USD.pm: -------------------------------------------------------------------------------- 1 | 2 | module Currency; 3 | 4 | class USD does Comparable, Printable { 5 | 6 | has $.amount : ro = 0; 7 | 8 | method compare ($other) { 9 | $.amount <=> $other->amount; 10 | } 11 | 12 | method to_string { 13 | sprintf '$%0.2f USD' => $.amount; 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /t/lib/Data/BinaryTree.pm: -------------------------------------------------------------------------------- 1 | 2 | module Data; 3 | 4 | class BinaryTree { 5 | 6 | has $.node : rw; 7 | has $.parent : ro : predicate; 8 | 9 | has $!left : predicate; 10 | has $!right : predicate; 11 | 12 | method left { $!left //= BinaryTree->new( parent => $self ) } 13 | method right { $!right //= BinaryTree->new( parent => $self ) } 14 | } 15 | -------------------------------------------------------------------------------- /t/lib/Eq.pm: -------------------------------------------------------------------------------- 1 | role Eq { 2 | method equal_to; 3 | 4 | method not_equal_to ($other) { 5 | not $self->equal_to($other); 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /t/lib/Finance/BankAccount.pm: -------------------------------------------------------------------------------- 1 | module Finance; 2 | 3 | class BankAccount { 4 | 5 | has $.balance : ro = 0; 6 | 7 | method deposit ($amount) { $.balance += $amount } 8 | 9 | method withdraw ($amount) { 10 | ($.balance >= $amount) 11 | || die "Account overdrawn"; 12 | $.balance -= $amount; 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /t/lib/Finance/CheckingAccount.pm: -------------------------------------------------------------------------------- 1 | 2 | module Finance; 3 | 4 | class CheckingAccount isa BankAccount { 5 | 6 | has $.overdraft_account : ro; 7 | 8 | method withdraw ($amount) { 9 | 10 | my $overdraft_amount = $amount - $self->balance; 11 | 12 | if ( $.overdraft_account && $overdraft_amount > 0 ) { 13 | $self->withdraw_from_overdraft( $overdraft_amount ); 14 | } 15 | 16 | $self->next::method( $amount ); 17 | } 18 | 19 | method withdraw_from_overdraft : private ($amount) { 20 | $.overdraft_account->withdraw( $amount ); 21 | $self->deposit( $amount ); 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /t/lib/Printable.pm: -------------------------------------------------------------------------------- 1 | role Printable { 2 | method to_string; 3 | } 4 | -------------------------------------------------------------------------------- /weaver.ini: -------------------------------------------------------------------------------- 1 | [@CorePrep] 2 | 3 | [Name] 4 | [Version] 5 | 6 | [Region / prelude] 7 | 8 | [Generic / SYNOPSIS] 9 | [Generic / DESCRIPTION] 10 | 11 | [Leftovers] 12 | 13 | [Region / postlude] 14 | 15 | [Authors] 16 | [Legal] 17 | --------------------------------------------------------------------------------