tito80 has asked for the wisdom of the Perl Monks concerning the following question:

I have a requirement to read a JSON/YAML file and build a Perl-based data structure dynamically based on the schema. The .yml file is basically the schema/template and the Perl data-structures would be classes with data-members, and methods to get/set those data members.

For e.g., the YAML hash keys might be class names, sub-keys would be data-members, and the sub-keys will have array/hash elements in turn to signify methods to get/set those data-members. Example below:

student: name: - get: <system_command_to_get_student_name> - set: <system_command_to_set_student_name> student_ID: - get: <system_command_to_get_student_name> - set: <system_command_to_set_student_name> ....
So I would have effectively have a class 'student' with data-members 'name' and 'student_ID', and appropriate 'get_student_name' and 'set_student_name' methods, etc. The schema can be edited easily to replace 'student' with 'employee' keeping the source code undisturbed. For e.g. the same source code should consume the following YAML tomorrow:
employee: SSN: - get: <system_command_to_get_SSN> - set: <system_command_to_set_SSN> pay: - get: <system_command_to_get_pay> - set: <system_command_to_set_pay> ....
I looked at Perl packages CLASS::MOP, Moose, MooseX::Declare, etc. but I have never used them earlier. Any kind of help from Perl gurus would be helpful.

Replies are listed 'Best First'.
Re: Building Perl classes dynamically based on an input schema/template
by davido (Cardinal) on Nov 11, 2016 at 23:27 UTC

    If you want to build this yourself, you can. A class is really just a namespace. Subroutines can be exported into any namespace by assigning a subref to the typeglob. Here's a simple example:

    package main; { no warnings 'once'; *main::foo = sub {print "Foo\n"} foo(); }

    This will print Foo. Our assignment of a subref in this case is virtually synonymous with this:

    package main; sub foo {print "Foo\n"}

    ...except that the typeglob version can be wielded dynamically. It can even be done in a BEGIN block. Now here is a fully functional implementation that installs a constructor, a getter, and a setter for a class that is described by a data structure.

    use strict; use warnings; my %classes = ( student => { name => [qw(get set)], id => [qw(get set)], }, ); foreach my $class (keys %classes) { my $cname = ucfirst $class; $cname =~ s/_(\w)/uc $1/eg; my @data_members; foreach my $data_member (keys %{$classes{$class}}) { push @data_members, $data_member; foreach my $accessor (@{$classes{$class}{$data_member}}) { if ($accessor eq 'get') { no strict 'refs'; no warnings 'once'; print "creating sub ${cname}::${data_member}_get\n"; *{$cname . '::' . $data_member . '_get'} = sub {my $se +lf = shift; return $self->{$data_member}}; } elsif ($accessor eq 'set') { no strict 'refs'; no warnings 'once'; print "creating sub ${cname}::${data_member}_set\n"; *{$cname . '::' . $data_member . '_set'} = sub {my $se +lf = shift; return $self->{$data_member} = shift}; } else { die "Unrecognized accessor type: ${cname}::${data_memb +er}_$accessor.\n"; } } } { no strict 'refs'; no warnings 'once'; print "creating sub ${cname}::new with data members (@data_mem +bers)\n"; *{$cname . '::' . 'new'} = sub { my ($class, $args) = @_; my $self = {}; $self->{$_} = $args->{$_} for keys %$args; return bless $self, $class; }; } } # Instantiate an object of class Student: my $s = Student->new({name => 'John Doe', id => 1234}); print "\n\n"; # Use the 'get' accessors for an object of class Student: print $s->id_get, ": ", $s->name_get, "\n"; # Use one of the 'set' accessors for the object: $s->name_set('Mark Doe'); # Verify the change: print $s->id_get, ": ", $s->name_get, "\n";

    The output will be:

    creating sub Student::name_get creating sub Student::name_set creating sub Student::id_get creating sub Student::id_set creating sub Student::new with data members (name id) 1234: John Doe 1234: Mark Doe

    Dave

      What about this variation?

      #!/usr/bin/env perl use strict; use warnings; use Cpanel::JSON::XS; use Data::Dump; use feature qw(say); my $json = <DATA>; my $class = decode_json $json; my $name = ( keys %$class )[0]; my $package = ucfirst $name; my $code = qq(package $package; use Class::Tiny qw( @{[ keys %{($class +->{$name}[1])} ]}); 1;); eval $code; my @objects = map {$package->new($_)} @{ $class->{$name} }; my @attributes = Class::Tiny->get_all_attributes_for($package); say $json; dd \@objects; dd \@attributes; say $code; say $package; for my $object(@objects) { for my $attribute( @attributes ) { say $object->$attribute; } } __DATA__ {"student": [{"name": "Nose", "id": "0001"}, {"name": "Cuke", "id":"00 +02"}]} __END__

      Just an idea. I'm not sure if it's sound and recommended and therefore i didn't reply to the OP.

      Thanks for any hint and regards, Karl

      «The Crux of the Biscuit is the Apostrophe»

        It works and is fairly elegant. :)

        Both are susceptible to someone using a class name that clobbers an existing namespace if the inputs are not trustworthy (or otherwise inept). I suppose that the eval version would allow for some sort of code injection beyond namespace collisions too, so again, the caveat about trustworthy, reliable inputs. In a real-world solution either one of our strategies should do thorough sanitization first.


        Dave