view release on metacpan or  search on metacpan

lib/Myco/Entity/Meta.pm  view on Meta::CPAN

                if ( $template_filtering eq 'block') {
                    # No thanks... schedule trashing of this attrs metadata
                    push @blocked_template_attrs, $aname;
                    next;
                }
            }

            # Make this template attrib a native attribute of this entity class
            delete $attr->{template};
            _gen_schema_field($class_schema, $aname, $attr);
            push @installed_template_attrs, $attr;

        }

        # Axe blocked template attributes
        map { delete $attributes->{$_} } @blocked_template_attrs;

        ## coderefs for this attribute's accessors
        foreach my $getset (qw(get set)) {
            my $accessor = $getset.'_'.$aname;
            my $code = UNIVERSAL::can($class, $accessor);
            unless ($code) {
                # No locally defined getter method... fall back
                # to the SUPER-ish 'get' / 'set'
                my $super_getset = UNIVERSAL::can($class, $getset);
                $code = do {
                    if ($getset eq 'get') {
                        sub { $super_getset->($_[0], $aname) }
                    } else {
                        sub { $super_getset->(shift, $aname, @_) }
                    }
                };
            }
            # This should never happen... since Class::Tangram's get()
            #   ain't goin' nowhere
            Myco::Exception::Meta->throw
              (error => "Class $class -- unable to locate coderef for " .
                        "method  $accessor")
                unless $code;
            my $md_acc_setter = 'set_'.$getset.'ter';
            $attr->$md_acc_setter($code);

        }
        # Set up ui->attribute_options hash
        my $attr_ui = $attr->get_ui;
        if (my $opts = $attr_ui->get_options) {
            for my $option ( keys %$opts ) {
                $meta_ui_attr_opts->{$option} = []
                  unless exists $meta_ui_attr_opts->{$option};
                push @{ $meta_ui_attr_opts->{$option} }, $aname;
            }
        }

        # Set up default ui->widget if needed
        my $values = $attr->get_values;
        my $widget = $attr_ui->get_widget;
        if ( defined $values and @$values
             and (!defined $widget
                  or ! @$widget
                  or $widget->[0] eq 'textfield')) {
            $attr_ui->set_widget( [ 'popup_menu' ]);
        }

        #######################################
        ## Enforce attrib 'readonly' nature
        #######################################
        if ( $attr->get_readonly ) {
            no strict 'refs';

            # install set_ATTRIB() blocker
            my $bad_setter = 'set_'.$aname;
            *{$class.'::'.$bad_setter} = sub {
                Myco::Exception::MNI->throw
                    (error => "unknown method/attribute $class"
                     . "->$bad_setter called.  Attribute is read-only");
            } unless UNIVERSAL::can($class, $bad_setter);

            # install ATTRIB() blocker
            *{$class.'::'.$aname} = sub {
                Myco::Exception::MNI->throw
                    (error => "unknown method/attribute ${class}->$aname"
                                                                   .'called');
            } unless UNIVERSAL::can($class, $aname);
        }
    }

    ## create proper displayname anon sub, if we can
    my $ui_dname_closure;
    if (my $dname_spec = $meta_ui->get_displayname) {
        # ui..displayname is set... turn it into a proper anon sub
        my $ui_dname_sub = do {
            my $dname_spec_type = ref $dname_spec;
            if (! $dname_spec_type) {
                # dname_spec is an attrib name... make sure it's valid
                Myco::Exception::Meta->throw
                  (error => "Class $class, 'ui displayname' specified with " .
                            "invalid attribute name")
                  unless exists $attributes->{$dname_spec};

                # fetch coderef to this attribute's getter method
                $attributes->{$dname_spec}->get_getter;

            } elsif ($dname_spec_type eq 'CODE') {
                # dname_spec itself is a coderef... hopefully it's correct!
                $dname_spec;
            } else {
                Myco::Exception::Meta->throw
                  (error => "Class $class, 'ui displayname' must be name of " .
                            "attribute or coderef");
            }
        };
        # Okay!  Now wrap it in an instance method friendly closure
        $ui_dname_closure = sub {
            my $referent = shift;
            Myco::Exception::Meta->throw
              (error => "displayname() error -- may only be called as " .
                        "instance method")
              unless ref $referent;
            # generate the displayname for $referent object
            return $ui_dname_sub->($referent);
        };

lib/Myco/Entity/Meta.pm  view on Meta::CPAN

                push @hits, $pkg;
                push @hits, _can($pkg, $meth);
            } else {
                push @hits, _can($pkg, $meth);
            }
        }
    }
    return @hits;
}

sub _parse_SQL_string_length {
    my ($attr, $opts) = @_;
    if (exists $opts->{sql}) {
        my ($length) = $opts->{sql} =~
          /\b(?:VAR)?CHAR\(\s*(\d*)\s*\)/i;
        if (defined $length) {
            my $type_opt = $attr->get_type_options;
            $attr->set_type_options( $type_opt = {} ) unless ref $type_opt;
            $type_opt->{string_length} = $length
        }
    }
}


sub _gen_schema_field {
    my ($class_schema, $newattr, $newmeta) = @_;

    my $type = $newmeta->get_type;
    my $tangram_opts = $newmeta->get_tangram_options || {};

    # Generate 'sql' option if meta data type_option 'string_length' is set
    if ( $type =~ /^\s*string\s*$/
         and exists($newmeta->{type_options})
         and defined($newmeta->{type_options}{string_length})
         and ! defined($tangram_opts->{sql}) ) {
        $tangram_opts->{sql} = 'VARCHAR('
          .$newmeta->{type_options}{string_length}.')';
    }
    # Add metadata-added attribute to $schema
    $class_schema->{fields}{$type}{$newattr} = $tangram_opts;
}



=head2 add_attribute

 $metadata->add_attribute(
   name => 'doneness',
   tangram_options => {required => 1},
   type => 'int',
   synopsis => "How you'd like your meat cooked",
   syntax_msg => "single number: 0 through 5",
   values => [qw(0 1 2 3 4, 5)],
   value_labels => {0 => 'rare',
                    1 => 'medium-rare',
                    2 => 'medium',
                    3 => 'medium-well',
                    4 => 'well',
                    5 => 'charred'},
   ui => { label => "Cook until..",
           widget => [ 'popup_menu' ] },
 );

Adds a Myco::Entity::Meta::Attribute object containing metadata
that describes an attribute.  Valid named parameters are as follows:

=over

=item * name  [required]

=item * readonly

=item * syntax_msg

=item * synopsis

=item * tangram_options

=item * template

=item * type  [required]

=item * type_options

=item * value_labels

=item * values

=item * ui

=back

For more detail see ATTRIBUTES section from
L<Myco::Entity::Meta::Attribute|Myco::Entity::Meta::Attribute>

Note:  an attribute declared via C<add_attribute()> overrides any same-named
attribute declared directly in a C<$schema data> structure.

=cut

sub add_attribute {
    my $self = shift;

    my $attributes = $self->get_attributes;
    $self->set_attributes($attributes = {}) unless (defined $attributes);
    my $attr = eval { Myco::Entity::Meta::Attribute->new(@_); };
    Myco::Exception::Meta->throw
      (error => "Exception during attempt to constuct the new ".
                "::Meta::Attribute metadata object for entity class " .
                $self->get_name .
                " - syntax error with add_attribute() parameters?  Raw " .
                "exception message:\n$@") if $@;
    $attributes->{$attr->get_name} = $attr;
}


=head2 add_query

 $metadata->add_query( %query_attributes );

Adds a Myco::Entity::Meta::Query object. For more detail see