File Coverage

blib/lib/DBIx/Class/Schema/Loader/DBObject.pm

Criterion	Covered	Total	%
statement	58	62	93.5
branch	11	16	68.7
condition	4	8	50.0
subroutine	17	17	100.0
pod	4	6	66.6
total	94	109	86.2

package DBIx::Class::Schema::Loader::DBObject;

use strict;
use warnings;
use base 'Class::Accessor::Grouped';
use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util 'weaken';
use namespace::clean;

=head1 NAME

DBIx::Class::Schema::Loader::DBObject - Base Class for Database Objects Such as
Tables and Views in L

=head1 METHODS

=head2 loader

The loader object this object is associated with, this is a required parameter
to L.

=head2 name

Name of the object. The object stringifies to this value.

=cut

__PACKAGE__->mk_group_accessors(simple => qw/
    loader
    name
    _schema
    ignore_schema
/);

use overload
    '""' => sub { $_[0]->name },
    '@{}' => sub { $_[0]->name_parts },
    fallback => 1;

=head2 new

The constructor, takes L, L, L, and L
as key-value parameters.

=cut

sub new {
    my $class = shift;

    my $self = { @_ };

    croak "loader is required" unless ref $self->{loader};

    weaken $self->{loader};

    $self->{_schema} = delete $self->{schema};

    return bless $self, $class;
}

=head2 clone

Make a shallow copy of the object.

=cut

sub clone {
    my $self = shift;

    return bless { %$self }, ref $self;
}

=head2 schema

The schema (or owner) of the object. Returns nothing if L is
true.

=head2 ignore_schema

Set to true to make L and L not use the defined L.
Does not affect L (for
L testing on
SQLite.)

=cut

sub schema {
    my $self = shift;

    return $self->_schema(@_) unless $self->ignore_schema;

    return undef;
}

sub _quote {
    my ($self, $identifier) = @_;

    $identifier = '' if not defined $identifier;

    my $qt = $self->loader->quote_char || '';

    if (length $qt > 1) {
        my @qt = split //, $qt;
        return $qt[0] . $identifier . $qt[1];
    }

    return "${qt}${identifier}${qt}";
}

=head1 sql_name

Returns the properly quoted full identifier with L and L.

=cut

sub sql_name {
    my $self = shift;

    my $name_sep = $self->loader->name_sep;

    if ($self->schema) {
        return $self->_quote($self->schema)
            . $name_sep
            . $self->_quote($self->name);
    }

    return $self->_quote($self->name);
}

=head1 dbic_name

Returns a value suitable for the C<< __PACKAGE__->table >> call in L Result files.

=cut

sub dbic_name {
    my $self = shift;

    my $name_sep = $self->loader->name_sep;

    if ($self->loader->qualify_objects && $self->_schema) {
        if ($self->_schema =~ /\W/ || $self->name =~ /\W/) {
            return \ $self->sql_name;
        }

        return $self->_schema . $name_sep . $self->name;
    }

    if ($self->name =~ /\W/) {
        return \ $self->_quote($self->name);
    }

    return $self->name;
}

=head2 name_parts

Returns an arrayref of the values returned by the methods specified in
the L of
the L object. The object arrayrefifies to this value.

=cut

sub name_parts {
    my ($self) = shift;
    return [ map { $self->$_ } @{$self->loader->moniker_parts} ];
}


=head1 SEE ALSO

L, L,
L

=head1 AUTHORS

See L.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
# vim:et sts=4 sw=4 tw=0: