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 17 18 94.4
pod 1 7 14.2
total 107 127 84.2


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-2021 -- leonerd@leonerd.org.uk
5              
6 14     14   250 use v5.26;
  14         49  
7 14     14   67 use Object::Pad 0.41;
  14         164  
  14         65  
8              
9             package Tangence::Struct 0.28;
10 14     14   5941 class Tangence::Struct isa Tangence::Meta::Struct;
  14         30  
  14         602  
11              
12 14     14   1763 use Carp;
  14         25  
  14         665  
13              
14 14     14   83 use Tangence::Type;
  14         24  
  14         307  
15 14     14   5120 use Tangence::Meta::Field;
  14         30  
  14         11676  
16              
17             our %STRUCTS_BY_NAME;
18             our %STRUCTS_BY_PERLNAME;
19              
20 69         95 sub make ( $class, %args )
21 69     69 0 113 {
  69         110  
  69         91  
22 69         106 my $name = $args{name};
23              
24 69   66     539 return $STRUCTS_BY_NAME{$name} //= $class->new( %args );
25             }
26              
27 57         78 sub declare ( $class, $perlname, %args )
  57         77  
28 57     57 0 164 {
  57         106  
  57         68  
29 57         239 ( my $name = $perlname ) =~ s{::}{.}g;
30 57 100       163 $name = $args{name} if $args{name};
31              
32 57         74 my @fields;
33 57         85 for( $_ = 0; $_ < @{$args{fields}}; $_ += 2 ) {
  199         414  
34             push @fields, Tangence::Meta::Field->new(
35             name => $args{fields}[$_],
36 142         516 type => Tangence::Type->make_from_sig( $args{fields}[$_+1] ),
37             );
38             }
39              
40 57         129 my $self = $class->make( name => $name );
41 57         228 $self->_set_perlname( $perlname );
42              
43 57         145 $self->define(
44             fields => \@fields,
45             );
46              
47 57         120 $STRUCTS_BY_PERLNAME{$perlname} = $self;
48 57         124 return $self;
49             }
50              
51             sub declare_builtin
52             {
53 56     56 0 80 my $class = shift;
54 56         125 my $self = $class->declare( @_ );
55              
56 56         186 $Tangence::Stream::ALWAYS_PEER_HASSTRUCT{$self->perlname} = [ $self, my $structid = ++$Tangence::Struct::BUILTIN_STRUCTIDS ];
57 56         125 $Tangence::Stream::BUILTIN_ID2STRUCT{$structid} = $self;
58              
59 56         79 return $self;
60             }
61              
62             sub define
63             {
64 67     67 1 88 my $self = shift;
65 67         248 $self->SUPER::define( @_ );
66              
67 67         152 my $class = $self->perlname;
68 67         212 my @fieldnames = map { $_->name } $self->fields;
  192         313  
69              
70             # Now construct the actual perl package
71 322         380 my %subs = (
72 322     322   335 new => sub ( $class, %args ) {
  322         663  
  322         651  
73 322   33     1146 exists $args{$_} or croak "$class is missing $_" for @fieldnames;
74 322         2058 bless [ @args{@fieldnames} ], $class;
75             },
76 67         427 );
77 67     849   215 $subs{$fieldnames[$_]} = do { my $i = $_; sub { shift->[$i] } } for 0 .. $#fieldnames;
  192     623   245  
  192         633  
  849         2693  
78              
79 14     14   113 no strict 'refs';
  14         25  
  14         9056  
80 67         185 foreach my $name ( keys %subs ) {
81 259 50       313 next if defined &{"${class}::${name}"};
  259         891  
82 259         342 *{"${class}::${name}"} = $subs{$name};
  259         981  
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         195 sub for_perlname ( $class, $perlname )
92 171     171 0 195 {
  171         198  
  171         181  
93 171   66     2115 return $STRUCTS_BY_PERLNAME{$perlname} // croak "Unknown Tangence::Struct for '$perlname'";
94             }
95              
96 57     57   93 has $perlname :writer(_set_perlname);
  57         97  
97              
98             method perlname
99 610     610 0 983 {
100 610 100       1968 return $perlname if defined $perlname;
101 10         83 ( $perlname = $self->name ) =~ s{\.}{::}g; # s///rg in 5.14
102 10         53 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;