File Coverage

blib/lib/Tangence/Struct.pm
Criterion Covered Total %
statement 79 84 94.0
branch 5 6 83.3
condition 5 12 41.6
subroutine 16 17 94.1
pod 1 7 14.2
total 106 126 84.1


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2012-2022 -- leonerd@leonerd.org.uk
5              
6 14     14   192 use v5.26;
  14         48  
7 14     14   73 use Object::Pad 0.57;
  14         219  
  14         70  
8              
9             package Tangence::Struct 0.30;
10 14     14   7500 class Tangence::Struct :isa(Tangence::Meta::Struct);
  14         35  
  14         783  
11              
12 14     14   2162 use Carp;
  14         33  
  14         778  
13              
14 14     14   83 use Tangence::Type;
  14         27  
  14         412  
15 14     14   5448 use Tangence::Meta::Field;
  14         34  
  14         13134  
16              
17             our %STRUCTS_BY_NAME;
18             our %STRUCTS_BY_PERLNAME;
19              
20 69         117 sub make ( $class, %args )
21 69     69 0 119 {
  69         157  
  69         99  
22 69         119 my $name = $args{name};
23              
24 69   66     628 return $STRUCTS_BY_NAME{$name} //= $class->new( %args );
25             }
26              
27 57         88 sub declare ( $class, $perlname, %args )
  57         85  
28 57     57 0 189 {
  57         140  
  57         83  
29 57         269 ( my $name = $perlname ) =~ s{::}{.}g;
30 57 100       190 $name = $args{name} if $args{name};
31              
32 57         92 my @fields;
33 57         98 for( $_ = 0; $_ < @{$args{fields}}; $_ += 2 ) {
  199         511  
34             push @fields, Tangence::Meta::Field->new(
35             name => $args{fields}[$_],
36 142         583 type => Tangence::Type->make_from_sig( $args{fields}[$_+1] ),
37             );
38             }
39              
40 57         150 my $self = $class->make( name => $name );
41 57         163 $self->_set_perlname( $perlname );
42              
43 57         152 $self->define(
44             fields => \@fields,
45             );
46              
47 57         145 $STRUCTS_BY_PERLNAME{$perlname} = $self;
48 57         148 return $self;
49             }
50              
51             sub declare_builtin
52             {
53 56     56 0 115 my $class = shift;
54 56         126 my $self = $class->declare( @_ );
55              
56 56         193 $Tangence::Stream::ALWAYS_PEER_HASSTRUCT{$self->perlname} = [ $self, my $structid = ++$Tangence::Struct::BUILTIN_STRUCTIDS ];
57 56         151 $Tangence::Stream::BUILTIN_ID2STRUCT{$structid} = $self;
58              
59 56         95 return $self;
60             }
61              
62             sub define
63             {
64 67     67 1 106 my $self = shift;
65 67         264 $self->SUPER::define( @_ );
66              
67 67         170 my $class = $self->perlname;
68 67         219 my @fieldnames = map { $_->name } $self->fields;
  192         372  
69              
70             # Now construct the actual perl package
71 322         494 my %subs = (
72 322     322   423 new => sub ( $class, %args ) {
  322         759  
  322         733  
73 322   33     1268 exists $args{$_} or croak "$class is missing $_" for @fieldnames;
74 322         2614 bless [ @args{@fieldnames} ], $class;
75             },
76 67         434 );
77 67     849   271 $subs{$fieldnames[$_]} = do { my $i = $_; sub { shift->[$i] } } for 0 .. $#fieldnames;
  192         289  
  192         759  
  849         2963  
78              
79 14     14   112 no strict 'refs';
  14         25  
  14         11010  
80 67         247 foreach my $name ( keys %subs ) {
81 259 50       394 next if defined &{"${class}::${name}"};
  259         1123  
82 259         413 *{"${class}::${name}"} = $subs{$name};
  259         1223  
83             }
84             }
85              
86 0         0 sub for_name ( $class, $name )
87 0     0 0 0 {
  0         0  
  0         0  
88 0   0     0 return $STRUCTS_BY_NAME{$name} // croak "Unknown Tangence::Struct for '$name'";
89             }
90              
91 171         239 sub for_perlname ( $class, $perlname )
92 171     171 0 245 {
  171         228  
  171         208  
93 171   66     2130 return $STRUCTS_BY_PERLNAME{$perlname} // croak "Unknown Tangence::Struct for '$perlname'";
94             }
95              
96 57     57   103 field $perlname :writer(_set_perlname);
  57         121  
97              
98             method perlname
99 610     610 0 1130 {
100 610 100       2338 return $perlname if defined $perlname;
101 10         71 ( $perlname = $self->name ) =~ s{\.}{::}g; # s///rg in 5.14
102 10         34 return $perlname;
103             }
104              
105             Tangence::Struct->declare_builtin(
106             "Tangence::Struct::Class",
107             name => "Tangence.Class",
108             fields => [
109             methods => "dict(any)",
110             events => "dict(any)",
111             properties => "dict(any)",
112             superclasses => "list(str)",
113             ],
114             );
115              
116             Tangence::Struct->declare_builtin(
117             "Tangence::Struct::Method",
118             name => "Tangence.Method",
119             fields => [
120             arguments => "list(str)",
121             returns => "str",
122             ],
123             );
124              
125             Tangence::Struct->declare_builtin(
126             "Tangence::Struct::Event",
127             name => "Tangence.Event",
128             fields => [
129             arguments => "list(str)",
130             ],
131             );
132              
133             Tangence::Struct->declare_builtin(
134             "Tangence::Struct::Property",
135             name => "Tangence.Property",
136             fields => [
137             dimension => "int",
138             type => "str",
139             smashed => "bool",
140             ],
141             );
142              
143             0x55AA;