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-2020 -- leonerd@leonerd.org.uk 5 6package Struct::Dumb; 7 8use strict; 9use warnings; 10 11our $VERSION = '0.12'; 12 13use Carp; 14 15use Scalar::Util qw( refaddr ); 16 17# 'overloading.pm' was only added in 5.10 18# Before that we can't easily implement forbidding of @{} overload, so lets not 19use constant HAVE_OVERLOADING => eval { require overloading }; 20 21=head1 NAME 22 23C<Struct::Dumb> - make simple lightweight record-like structures 24 25=head1 SYNOPSIS 26 27 use Struct::Dumb; 28 29 struct Point => [qw( x y )]; 30 31 my $point = Point(10, 20); 32 33 printf "Point is at (%d, %d)\n", $point->x, $point->y; 34 35 $point->y = 30; 36 printf "Point is now at (%d, %d)\n", $point->x, $point->y; 37 38Z<> 39 40 struct Point3D => [qw( x y z )], named_constructor => 1; 41 42 my $point3d = Point3D( z => 12, x => 100, y => 50 ); 43 44 printf "Point3d's height is %d\n", $point3d->z; 45 46Z<> 47 48 struct Point3D => [qw( x y z )], predicate => "is_Point3D"; 49 50 my $point3d = Point3D( 1, 2, 3 ); 51 52 printf "This is a Point3D\n" if is_Point3D( $point3d ); 53 54Z<> 55 56 use Struct::Dumb qw( -named_constructors ) 57 58 struct Point3D => [qw( x y z )]; 59 60 my $point3d = Point3D( x => 100, z => 12, y => 50 ); 61 62=head1 DESCRIPTION 63 64C<Struct::Dumb> creates record-like structure types, similar to the C<struct> 65keyword in C, C++ or C#, or C<Record> in Pascal. An invocation of this module 66will create a construction function which returns new object references with 67the given field values. These references all respond to lvalue methods that 68access or modify the values stored. 69 70It's specifically and intentionally not meant to be an object class. You 71cannot subclass it. You cannot provide additional methods. You cannot apply 72roles or mixins or metaclasses or traits or antlers or whatever else is in 73fashion this week. 74 75On the other hand, it is tiny, creates cheap lightweight array-backed 76structures, uses nothing outside of core. It's intended simply to be a 77slightly nicer way to store data structures, where otherwise you might be 78tempted to abuse a hash, complete with the risk of typoing key names. The 79constructor will C<croak> if passed the wrong number of arguments, as will 80attempts to refer to fields that don't exist. Accessor-mutators will C<croak> 81if invoked with arguments. (This helps detect likely bugs such as accidentally 82passing in the new value as an argument, or attempting to invoke a stored 83C<CODE> reference by passing argument values directly to the accessor.) 84 85 $ perl -E 'use Struct::Dumb; struct Point => [qw( x y )]; Point(30)' 86 usage: main::Point($x, $y) at -e line 1 87 88 $ perl -E 'use Struct::Dumb; struct Point => [qw( x y )]; Point(10,20)->z' 89 main::Point does not have a 'z' field at -e line 1 90 91 $ perl -E 'use Struct::Dumb; struct Point => [qw( x y )]; Point(1,2)->x(3)' 92 main::Point->x invoked with arguments at -e line 1. 93 94Objects in this class are (currently) backed by an ARRAY reference store, 95though this is an internal implementation detail and should not be relied on 96by using code. Attempting to dereference the object as an ARRAY will throw an 97exception. 98 99=head2 CONSTRUCTOR FORMS 100 101The C<struct> and C<readonly_struct> declarations create two different kinds 102of constructor function, depending on the setting of the C<named_constructor> 103option. When false, the constructor takes positional values in the same order 104as the fields were declared. When true, the constructor takes a key/value pair 105list in no particular order, giving the value of each named field. 106 107This option can be specified to the C<struct> and C<readonly_struct> 108functions. It defaults to false, but it can be set on a per-package basis to 109default true by supplying the C<-named_constructors> option on the C<use> 110statement. 111 112When using named constructors, individual fields may be declared as being 113optional. By preceeding the field name with a C<?> character, the constructor 114is instructed not to complain if a named parameter is not given for that 115field; instead it will be set to C<undef>. 116 117 struct Person => [qw( name age ?address )], 118 named_constructor => 1; 119 120 my $bob = Person( name => "Bob", age => 20 ); 121 # This is valid because 'address' is marked as optional 122 123=cut 124 125sub import 126{ 127 my $pkg = shift; 128 my $caller = caller; 129 130 my %default_opts; 131 my %syms; 132 133 foreach ( @_ ) { 134 if( $_ eq "-named_constructors" ) { 135 $default_opts{named_constructor} = 1; 136 } 137 else { 138 $syms{$_}++; 139 } 140 } 141 142 keys %syms or $syms{struct}++; 143 144 my %export; 145 146 if( delete $syms{struct} ) { 147 $export{struct} = sub { 148 my ( $name, $fields, @opts ) = @_; 149 _struct( $name, $fields, scalar caller, lvalue => 1, %default_opts, @opts ); 150 }; 151 } 152 if( delete $syms{readonly_struct} ) { 153 $export{readonly_struct} = sub { 154 my ( $name, $fields, @opts ) = @_; 155 _struct( $name, $fields, scalar caller, lvalue => 0, %default_opts, @opts ); 156 }; 157 } 158 159 if( keys %syms ) { 160 croak "Unrecognised export symbols " . join( ", ", keys %syms ); 161 } 162 163 no strict 'refs'; 164 *{"${caller}::$_"} = $export{$_} for keys %export; 165} 166 167=head1 FUNCTIONS 168 169=cut 170 171my %_STRUCT_PACKAGES; 172 173sub _struct 174{ 175 my ( $name, $_fields, $caller, %opts ) = @_; 176 177 my $lvalue = !!$opts{lvalue}; 178 my $named = !!$opts{named_constructor}; 179 180 my $pkg = "${caller}::$name"; 181 182 my @fields = @$_fields; 183 184 my %optional; 185 s/^\?// and $optional{$_}++ for @fields; 186 187 my $constructor; 188 if( $named ) { 189 $constructor = sub { 190 my %values = @_; 191 my @values; 192 foreach ( @fields ) { 193 exists $values{$_} or $optional{$_} or 194 croak "usage: $pkg requires '$_'"; 195 push @values, delete $values{$_}; 196 } 197 if( my ( $extrakey ) = keys %values ) { 198 croak "usage: $pkg does not recognise '$extrakey'"; 199 } 200 bless \@values, $pkg; 201 }; 202 } 203 else { 204 my $fieldcount = @fields; 205 my $argnames = join ", ", map "\$$_", @fields; 206 $constructor = sub { 207 @_ == $fieldcount or croak "usage: $pkg($argnames)"; 208 bless [ @_ ], $pkg; 209 }; 210 } 211 212 my %subs; 213 foreach ( 0 .. $#fields ) { 214 my $idx = $_; 215 my $field = $fields[$idx]; 216 217 BEGIN { 218 overloading->unimport if HAVE_OVERLOADING; 219 } 220 221 $subs{$field} = $lvalue 222 ? sub :lvalue { @_ > 1 and croak "$pkg->$field invoked with arguments"; 223 shift->[$idx] } 224 : sub { @_ > 1 and croak "$pkg->$field invoked with arguments"; 225 shift->[$idx] }; 226 } 227 $subs{DESTROY} = sub {}; 228 $subs{AUTOLOAD} = sub :lvalue { 229 my ( $field ) = our $AUTOLOAD =~ m/::([^:]+)$/; 230 croak "$pkg does not have a '$field' field"; 231 my $dummy; ## croak can't be last because it isn't lvalue, so this line is required 232 }; 233 234 no strict 'refs'; 235 *{"${pkg}::$_"} = $subs{$_} for keys %subs; 236 *{"${caller}::$name"} = $constructor; 237 238 if( my $predicate = $opts{predicate} ) { 239 *{"${caller}::$predicate"} = sub { ( ref($_[0]) || "" ) eq $pkg }; 240 } 241 242 *{"${pkg}::_forbid_arrayification"} = sub { 243 return if !HAVE_OVERLOADING and caller eq __PACKAGE__; 244 croak "Cannot use $pkg as an ARRAY reference" 245 }; 246 247 require overload; 248 $pkg->overload::OVERLOAD( 249 '@{}' => sub { $_[0]->_forbid_arrayification; return $_[0] }, 250 '0+' => sub { refaddr $_[0] }, 251 '""' => sub { sprintf "%s=Struct::Dumb(%#x)", $pkg, refaddr $_[0] }, 252 'bool' => sub { 1 }, 253 fallback => 1, 254 ); 255 256 $_STRUCT_PACKAGES{$pkg} = { 257 named => $named, 258 fields => \@fields, 259 } 260} 261 262=head2 struct 263 264 struct $name => [ @fieldnames ], 265 named_constructor => (1|0), 266 predicate => "is_$name"; 267 268Creates a new structure type. This exports a new function of the type's name 269into the caller's namespace. Invoking this function returns a new instance of 270a type that implements those field names, as accessors and mutators for the 271fields. 272 273Takes the following options: 274 275=over 4 276 277=item named_constructor => BOOL 278 279Determines whether the structure will take positional or named arguments. 280 281=item predicate => STR 282 283If defined, gives the name of a second function to export to the caller's 284namespace. This function will be a type test predicate; that is, a function 285that takes a single argmuent, and returns true if-and-only-if that argument is 286an instance of this structure type. 287 288=back 289 290=cut 291 292=head2 readonly_struct 293 294 readonly_struct $name => [ @fieldnames ], 295 ... 296 297Similar to L</struct>, but instances of this type are immutable once 298constructed. The field accessor methods will not be marked with the 299C<:lvalue> attribute. 300 301Takes the same options as L</struct>. 302 303=cut 304 305=head1 DATA::DUMP FILTER 306 307I<Since version 0.10.> 308 309If L<Data::Dump> is loaded, an extra filter is applied so that struct 310instances are printed in a format matching that which would construct them. 311 312 struct Colour => [qw( red green blue )]; 313 314 use Data::Dump; 315 316 my %hash = ( col => Colour( 0.8, 0.5, 0.2 ) ); 317 Data::Dump::dd \%hash; 318 319 # prints {col => main::Colour(0.8, 0.5, 0.2)} 320 321=head1 NOTES 322 323=head2 Allowing ARRAY dereference 324 325The way that forbidding access to instances as if they were ARRAY references 326is currently implemented uses an internal method on the generated structure 327class called C<_forbid_arrayification>. If special circumstances require that 328this exception mechanism be bypassed, the method can be overloaded with an 329empty C<sub {}> body, allowing the struct instances in that class to be 330accessed like normal ARRAY references. For good practice this should be 331limited by a C<local> override. 332 333For example, L<Devel::Cycle> needs to access the instances as plain ARRAY 334references so it can walk the data structure looking for reference cycles. 335 336 use Devel::Cycle; 337 338 { 339 no warnings 'redefine'; 340 local *Point::_forbid_arrayification = sub {}; 341 342 memory_cycle_ok( $point ); 343 } 344 345=head1 TODO 346 347=over 4 348 349=item * 350 351Consider adding an C<coerce_hash> option, giving name of another function to 352convert structs to key/value pairs, or a HASH ref. 353 354=back 355 356=head1 AUTHOR 357 358Paul Evans <leonerd@leonerd.org.uk> 359 360=cut 361 362sub maybe_apply_datadump_filter 363{ 364 return unless $INC{"Data/Dump.pm"}; 365 366 require Data::Dump::Filtered; 367 368 Data::Dump::Filtered::add_dump_filter( sub { 369 my ( $ctx, $obj ) = @_; 370 return undef unless my $meta = $_STRUCT_PACKAGES{ $ctx->class }; 371 372 BEGIN { 373 overloading->unimport if HAVE_OVERLOADING; 374 } 375 376 my $fields = $meta->{fields}; 377 return { 378 dump => sprintf "%s(%s)", $ctx->class, 379 join ", ", map { 380 ( $meta->{named} ? "$fields->[$_] => " : "" ) . 381 Data::Dump::dump($obj->[$_]) 382 } 0 .. $#$fields 383 }; 384 }); 385} 386 387if( defined &Data::Dump::dump ) { 388 maybe_apply_datadump_filter; 389} 390else { 391 # A package var we observe that Data/Dump.pm seems to set when loaded 392 # We can't attach to VERSION because too many other things get upset by 393 # that. 394 $Data::Dump::DEBUG = bless \( my $x = \&maybe_apply_datadump_filter ), 395 "Struct::Dumb::_DestroyWatch"; 396} 397 398{ 399 package Struct::Dumb::_DestroyWatch; 400 my $GD = 0; 401 END { $GD = 1 } 402 sub DESTROY { ${$_[0]}->() unless $GD; } 403} 404 4050x55AA; 406