DBIx::Class::RDBOHelpers - DBIC compat with Rose::DBx::Object::MoreHelpers

 package MyDB::Schema::Foo;
 use strict;

 use base 'DBIx::Class';

 __PACKAGE__->load_components(qw( RDBOHelpers Core ));
 # ... rest of schema setup here

 if (my $group_count = $user->has_related('groups')) {
     printf("user %s has %d related groups\n", 
        $user->name, $group_count);
 }
 else {
     printf("User %s has no related groups\n", 
        $user->name);
 }

    perldoc DBIx::Class::RDBOHelpers

package DBIx::Class::RDBOHelpers;

use warnings;
use strict;
use base 'DBIx::Class';
use Carp;
use Data::Dump qw( dump );

our $VERSION = '0.09';

sub has_related {
    my $self = shift;
    my $rel  = shift;
    my $c    = $self->$rel->count;
    return $c;
}

sub has_related_pages {
    my $self   = shift;
    my $rel    = shift or croak "need Relationship name";
    my $pgsize = shift or croak "need page_size";
    if ( $pgsize =~ m/\D/ ) {
        croak "page_size must be an integer";
    }
    my $n = $self->has_related($rel);
    return 0 if !$n;
    if ( $n % $pgsize ) {
        return int( $n / $pgsize ) + 1;
    }
    else {
        return $n / $pgsize;
    }
}

sub primary_key_uri_escaped {
    my $self = shift;
    my $val  = $self->primary_key_value;
    my @vals = ref $val ? @$val : ($val);
    my @esc;
    for my $v (@vals) {
        $v = '' unless defined $v;
        $v =~ s/;/\%3b/g;
        push @esc, $v;
    }
    if ( !grep { length($_) } @esc ) {
        return 0;
    }
    my $pk = join( ';;', @esc );
    $pk =~ s!/!\%2f!g;
    return $pk;
}

sub primary_key_value {
    my $self = shift;
    my @vals = map { $self->$_ } $self->primary_columns;
    return scalar(@vals) > 1 ? \@vals : $vals[0];
}

__PACKAGE__->mk_classdata( ___my_m2m_metadata => {} );

sub many_to_many {
    my $class = shift;
    my ( $meth_name, $rel_name, $map_to ) = @_;
    my $store = $class->___my_m2m_metadata;
    croak("many_to_many metadata for $meth_name already exists")
        if exists $store->{$meth_name};

    my $attrs = {
        class       => $class,
        method_name => $meth_name,
        rel_name    => $rel_name,    # the o2m relationship name
        map_to      => $map_to,      # i.e., foreign class method name
        ( @_ > 3 ? ( attrs => $_[3] ) : () ),    # only store if exists
    };

    # inheritable data workaround
    $class->___my_m2m_metadata( { $rel_name => $attrs, %$store } );

    $class->next::method(@_);
}

sub relationship_info {
    my $self     = shift;
    my $rel_name = shift;
    my $info     = $self->next::method($rel_name);

    my $class = ref($self) ? ref($self) : $self;

    #carp dump $self;

    # if this is a m2m relname, construct hash ref of
    # m2m + foreign_relation info
    if ( exists $class->___my_m2m_metadata->{$rel_name} ) {

        # return if we've already set it up.
        return $info if exists $info->{m2m};

        # set up
        my %m2m = %{ $class->___my_m2m_metadata->{$rel_name} };
        $m2m{map_class} = $info->{class};

        # find the missing map_from value
        for my $map_rel ( $m2m{map_class}->relationships ) {
            my $map_rel_info = $m2m{map_class}->relationship_info($map_rel);

#warn
#    "$rel_name : map_rel_info for class $class with map_class $m2m{map_class}"
#    . dump $map_rel_info;

            # gah. this is broken for Catalyst because each ResultSource
            # is blessed into a Model::Schema::$moniker class
            # so can't compare with 'eq'. must trust isa() instead.

            #warn "class->isa  $class -> $map_rel_info->{class}";

            if ( scalar keys %{ $map_rel_info->{cond} } > 1 ) {
                warn
                    "multi-key conditions for m2m relationships are not yet supported";
                next;
            }

            for my $foreign ( keys %{ $map_rel_info->{cond} } ) {
                my $local = $map_rel_info->{cond}->{$foreign};
                $local   =~ s/^self\.//;
                $foreign =~ s/^foreign\.//;

                if ( $class->isa( $map_rel_info->{class} ) ) {

                    # because this might be a many2many related to itself,
                    # we double check whether map_from eq map_to
                    # and skip on a match

                    if ( $map_rel eq $m2m{map_to} ) {
                        $m2m{foreign_class}  = $map_rel_info->{class};
                        $m2m{foreign_column} = $foreign;
                        $m2m{map_to_column}  = $local;
                    }
                    else {
                        $m2m{class_column}    = $foreign;
                        $m2m{map_from}        = $map_rel;
                        $m2m{map_from_column} = $local;
                    }

                }
                else {
                    $m2m{foreign_class}  = $map_rel_info->{class};
                    $m2m{foreign_column} = $foreign;
                    $m2m{map_to_column}  = $local;
                }

                # only deal with first one defined.
                # TODO could there be more?
                last;
            }

        }

        #carp "made m2m: " . dump \%m2m;

        # stash it away
        $info->{m2m} = \%m2m;

    }

    return $info;

}

sub column_is_boolean {
    my $self     = shift;
    my $col_name = shift;
    croak "column_name required" unless defined $col_name;

    return 0 unless $self->has_column($col_name);

    my $col_info = $self->column_info($col_name);
    if ( exists $col_info->{data_type}
        and $col_info->{data_type} eq 'boolean' )
    {
        return 1;
    }

    return 0;
}

sub unique_value {
    my $self = shift;

    # find the first unique single-col column of type char/varchar
    for my $constraint ( $self->unique_constraint_names ) {
        my @u = $self->unique_constraint_columns($constraint);
        next if @u > 1;
        my $method = $u[0];
        return $self->$method;
    }

    # couldn't find a unique column. use PK
    my @pk = $self->primary_columns;
    return join( ' ', map { $self->$_ } @pk );

}

1;

__END__