+++ /dev/null
-package DBIx::Class::TokenGroup;
-use strict;
-use warnings;
-
-use base qw( DBIx::Class );
-
-=head1 NAME
-
-DBIx::Class::TokenGroup - Search for tokens in a tree of groups. (EXPERIMENTAL)
-
-=head1 SYNOPSIS
-
-Define your user tokens class.
-
- package Schema::User::Token;
- use base qw( DBIx::Class::Core );
- __PACKAGE__->table('user_tokens');
- __PACKAGE__->add_columns(qw( name user_id value ));
- __PACKAGE__->set_primary_key(qw( name user_id ));
- 1;
-
-Define your group tokens class.
-
- package Schema::Group::Token;
- use base qw( DBIx::Class::Core );
- __PACKAGE__->table('group_tokens');
- __PACKAGE__->add_columns(qw( name group_id value ));
- __PACKAGE__->set_primary_key(qw( name group_id ));
- 1;
-
-Define your group class.
-
- package Schema::Group;
- use base qw( DBIx::Class::Core );
- __PACKAGE__->load_components(qw(
- Tree::AdjacencyList
- ));
- __PACKAGE__->table('groups');
- __PACKAGE__->add_columns(qw( group_id parent_id ));
- __PACKAGE__->set_primary_key('group_id');
- __PACKAGE__->parent_column('parent_id');
- __PACKAGE__->has_many( 'tokens' => 'Group::Token' => 'group_id' );
- 1;
-
-Define your user class.
-
- package Schema::User;
- use base qw( DBIx::Class::Core );
- __PACKAGE__->table('users');
- __PACKAGE__->add_columns(qw( user_id group_id ));
- __PACKAGE__->set_primary_key('user_id');
- __PACKAGE__->token_name_column('name');
- __PACKAGE__->token_value_column('value');
- __PACKAGE__->has_many( 'tokens' => 'User::Token' => 'user_id' );
- __PACKAGE__->belongs_to( 'group' => 'Group', { 'foreign.group_id' => 'self.group_id' } );
- 1;
-
-=head1 DESCRIPTION
-
-This L<DBIx::Class> component provides several utilities for
-retrieving tokens for a tree of groups. A token is, at a minimum,
-a name and a value. Groups are associated using either
-L<DBIx::Class::Tree::AdjacencyList> or L<DBIx::Class::Tree::NestedSet>.
-
-This component itself is fairly simple, but it requires that you
-structure your classes in a certain way.
-
-=head1 REQUIREMENTS
-
-The sample shown in the SYNOPSIS is just that, an example.
-As long your clases respond the way that this component
-expects it doesn't care how things are structure. So, here
-are the requirements for the class that uses this component.
-
-=over 4
-
-=item *
-
-A tokens() method that returns a DBIx::Class::ResultSet object. The
-objects (tokens) that the result set returns must have the name and
-value columns that you specified with the...
-
-=item *
-
-TODO
-
-=back
-
-=head1 METHODS
-
-=head2 token_name_column
-
- __PACKAGE__->token_name_column('name');
-
-Sets the name of the column that can be queried to
-retrieve a token's name.
-
-=cut
-
-__PACKAGE__->mk_classdata( 'token_name_column' => 'name' );
-
-=head2 token_value_column
-
- __PACKAGE__->token_value_column('value');
-
-Sets the name of the column that can be queried to
-retrieve a token's value. This settings is optional
-as long as you do not use the token_true() and
-token_false() methods.
-
-=cut
-
-__PACKAGE__->mk_classdata( 'token_value_column' => 'value' );
-
-=head2 token
-
- $object->token('name');
-
-Returns the token object, or 0 if none was found.
-
-=cut
-
-sub token {
- my( $self, $name ) = @_;
- my $name_col = $self->token_name_column();
- my $token = $self->tokens->search({
- $name_col => $name
- })->all();
- return $token if ($token);
- $token = $self->group->tokens->search({
- $name_col => $name
- })->all();
- return $token if ($token);
- my $descendant = $self->group->descendant_by_depth();
- while (my $group = $descendant->next()) {
- $token = $group->tokens->search({
- $name_col => $name
- })->all();
- return $token if ($token);
- }
- return 0;
-}
-
-=head2 token_exists
-
- if ($object->token_exists('name')){ ... }
-
-Tests whether there is a token defined of the
-specified name.
-
-=cut
-
-sub token_exists {
- my( $self, $name ) = @_;
- my $name_col = $self->token_name_column();
- return 1 if( $self->tokens->search({
- $name_col => $name
- })->count() );
- return 1 if( $self->group->tokens->search({
- $name_col => $name
- })->count() );
- my $ancestors = $self->group->ancestors_by_depth();
- while (my $group = $ancestors->next()) {
- return 1 if( $group->tokens->search({
- $name_col => $name
- })->count() );
- }
- return 0;
-}
-
-=head2 token_true
-
- if ($object->token_true('name')) {
-
-Returns 1 if the token exists and its value is a
-true value. Returns 0 otherwise.
-
-=cut
-
-sub token_true {
- my( $self, $name ) = @_;
- my $token = $self->token( $name );
- return 0 if(!$token);
- return ( $token->get_column($self->token_value_column()) ? 1 : 0 );
-}
-
-=head2 token_false
-
- if ($object->token_false('name')) {
-
-Returns 1 if the token exists and its value is a
-false value. Returns 0 otherwise.
-
-=cut
-
-sub token_false {
- my( $self, $name ) = @_;
- my $token = $self->token( $name );
- return 0 if(!$token);
- return ( $token->get_column($self->token_value_column()) ? 0 : 1 );
-}
-
-1;
-__END__
-
-=head1 AUTHOR
-
-Aran Clary Deltac <bluefeet@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
+++ /dev/null
-# vim: ts=8:sw=4:sts=4:et
-package DBIx::Class::Tree::AdjacencyList;
-use strict;
-use warnings;
-use base qw( DBIx::Class );
-use Carp qw( croak );
-
-=head1 NAME
-
-DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model.
-
-=head1 SYNOPSIS
-
-Create a table for your tree data.
-
- CREATE TABLE employees (
- employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
- parent_id INTEGER NOT NULL,
- name TEXT NOT NULL
- );
-
-In your Schema or DB class add Tree::AdjacencyList to the top
-of the component list.
-
- __PACKAGE__->load_components(qw( Tree::AdjacencyList ... ));
- # If you want positionable data make sure this
- # module comes first, as in:
- __PACKAGE__->load_components(qw( Tree::AdjacencyList Positional ... ));
-
-Specify the column that contains the parent ID each row.
-
- package My::Employee;
- __PACKAGE__->parent_column('parent_id');
-
-Thats it, now you can modify and analyze the tree.
-
- #!/use/bin/perl
- use My::Employee;
-
- my $employee = My::Employee->create({ name=>'Matt S. Trout' });
-
- my $rs = $employee->children();
- my @siblings = $employee->children();
-
- my $parent = $employee->parent();
- $employee->parent( 7 );
-
-=head1 DESCRIPTION
-
-This module provides methods for working with adjacency lists. The
-adjacency list model is a very common way of representing a tree structure.
-In this model each row in a table has a prent ID column that references the
-primary key of another row in the same table. Because of this the primary
-key must only be one column and is usually some sort of integer. The row
-with a parent ID of 0 is the root row and is usually the parent of all
-other rows.
-
-=head1 METHODS
-
-=head2 parent_column
-
- __PACKAGE__->parent_column('parent_id');
-
-Declares the name of the column that contains the self-referential
-ID which defines the parent row. Defaults to "parent_id".
-
-If you are useing the L<DBIx::Class::Positional> component then this
-parent_column will automatically be used as the collection_column.
-
-=cut
-
-__PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' );
-
-=head2 parent
-
- my $parent = $employee->parent();
- $employee->parent( $parent_obj );
- $employee->parent( $parent_id );
-
-Retrieves the object's parent ID, or sets the object's
-parent ID. If setting the parent ID then 0 will be returned
-if the object already has the specified parent, and 1 on
-success.
-
-If you are using the L<DBIx::Class::Positional> component this
-module will first move the object to the last position of
-the list, change the parent ID, then move the object to the
-last position of the new list. This ensures the intergrity
-of the positions.
-
-=cut
-
-sub parent {
- my( $self, $new_parent ) = @_;
- my $parent_column = $self->parent_column();
- if ($new_parent) {
- if (ref($new_parent)) {
- $new_parent = $new_parent->id() || 0;
- }
- return 0 if ($new_parent == ($self->get_column($parent_column)||0));
- $self->move_last() if ($self->positional());
- $self->set_column( $parent_column => $new_parent );
- if ($self->positional()) {
- $self->set_column(
- $self->position_column() => $self->search( {$self->_collection_clause()} )->count() + 1
- );
- }
- $self->update();
- return 1;
- }
- else {
- return $self->find( $self->get_column( $parent_column ) );
- }
-}
-
-=head2 children
-
- my $children_rs = $employee->children();
- my @children = $employee->children();
-
-Returns a list or record set, depending on context, of all
-the objects one level below the current one.
-
-If you are using the L<DBIx::Class::Positional> component then this method
-will return the children sorted by the position column.
-
-=cut
-
-sub children {
- my( $self ) = @_;
- my $rs = $self->search(
- { $self->parent_column()=>$self->id() },
- ( $self->isa('DBIx::Class::Position') ? {order_by=>$self->position_column()} : () )
- );
- return $rs->all() if (wantarray());
- return $rs;
-}
-
-=head2 attach_child
-
- $parent->attach_child( $child );
-
-Sets (or moves) the child to the new parent.
-
-=cut
-
-sub attach_child {
- my( $self, $child ) = @_;
- $child->parent( $self );
-}
-
-=head2 attach_sibling
-
- $this->attach_sibling( $that );
-
-Sets the passed in object to have the same parent
-as the calling object.
-
-=cut
-
-sub attach_sibling {
- my( $self, $child ) = @_;
- $child->parent( $self->parent() );
-}
-
-=head1 POSITIONAL METHODS
-
-If you are useing the L<DBIx::Class::Postional> component
-in conjunction with this module then you will also have
-these methods available to you.
-
-=head2 append_child
-
- $parent->append_child( $child );
-
-Sets the child to have the specified parent and moves the
-child to the last position.
-
-=cut
-
-sub append_child {
- my( $self, $child ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $child->parent( $self );
-}
-
-=head2 prepend_child
-
- $parent->prepend_child( $child );
-
-Sets the child to have the specified parent and moves the
-child to the first position.
-
-=cut
-
-sub prepend_child {
- my( $self, $child ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $child->parent( $self );
- $child->move_first();
-}
-
-=head2 attach_before
-
- $this->attach_before( $that );
-
-Attaches the object at the position just before the
-calling object's position.
-
-=cut
-
-sub attach_before {
- my( $self, $sibling ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $sibling->parent( $self->parent() );
- $sibling->move_to( $self->get_column($self->position_column()) );
-}
-
-=head2 attach_after
-
- $this->attach_after( $that );
-
-Attaches the object at the position just after the
-calling object's position.
-
-=cut
-
-sub attach_after {
- my( $self, $sibling ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $sibling->parent( $self->parent() );
- $sibling->move_to( $self->get_column($self->position_column()) + 1 );
-}
-
-=head2 positional
-
- if ($object->positional()) { ... }
-
-Returns true if the object is a DBIx::Class::Positional
-object.
-
-=cut
-
-sub positional {
- my( $self ) = @_;
- return $self->isa('DBIx::Class::Positional');
-}
-
-=head1 PRIVATE METHODS
-
-These methods are used internally. You should never have the
-need to use them.
-
-=head2 _collection_clause
-
-This method is provided as an override of the method in
-L<DBIx::Class::Positional>. This way Positional and Tree::AdjacencyList
-may be used together without conflict. Make sure that in
-your component list that you load Tree::AdjacencyList before you
-load Positional.
-
-=cut
-
-sub _collection_clause {
- my( $self ) = @_;
- return (
- $self->parent_column() =>
- $self->get_column($self->parent_column())
- );
-}
-
-1;
-__END__
-
-=head1 AUTHOR
-
-Aran Clary Deltac <bluefeet@cpan.org>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
+++ /dev/null
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-use DBICTest::HelperRels;
-
-require "t/run/27adjacency_list.tl";
-run_tests(DBICTest->schema);
__PACKAGE__->load_classes(qw/
Artist
- Employee::Positional
- Employee::AdjacencyList
+ Employee
CD
#dummy
Track
package # hide from PAUSE
- DBICTest::Schema::Employee::Positional;
+ DBICTest::Schema::Employee;
use base 'DBIx::Class';
__PACKAGE__->load_components(qw( Positional PK::Auto Core ));
-__PACKAGE__->table('employees_positional');
+__PACKAGE__->table('employees');
__PACKAGE__->add_columns(
employee_id => {
+++ /dev/null
-package # hide from PAUSE
- DBICTest::Schema::Employee::AdjacencyList;
-
-use base 'DBIx::Class';
-
-__PACKAGE__->load_components(qw(
- Tree::AdjacencyList
- Positional
- PK::Auto
- Core
-));
-
-__PACKAGE__->table('employees_adjacencylist');
-
-__PACKAGE__->add_columns(
- employee_id => {
- data_type => 'integer',
- is_auto_increment => 1
- },
- parent_id => {
- data_type => 'integer',
- },
- position => {
- data_type => 'integer',
- is_nullable => 1,
- },
- name => {
- data_type => 'varchar',
- size => 100,
- is_nullable => 1,
- },
-);
-
-__PACKAGE__->set_primary_key('employee_id');
-__PACKAGE__->parent_column('parent_id');
-__PACKAGE__->position_column('position');
-
-__PACKAGE__->mk_classdata('field_name_for', {
- employee_id => 'primary key',
- parent_id => 'parent id',
- position => 'list order',
- name => 'employee name',
-});
-
-1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Fri Mar 24 07:13:26 2006
+-- Created on Fri Mar 24 15:47:00 2006
--
BEGIN TRANSACTION;
--
+-- Table: employees
+--
+CREATE TABLE employees (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
+ position integer NOT NULL,
+ group_id integer,
+ name varchar(100)
+);
+
+--
-- Table: serialized
--
CREATE TABLE serialized (
);
--
--- Table: employees_adjacencylist
+-- Table: cd_to_producer
--
-CREATE TABLE employees_adjacencylist (
- employee_id INTEGER PRIMARY KEY NOT NULL,
- parent_id integer NOT NULL,
- position integer,
- name varchar(100)
+CREATE TABLE cd_to_producer (
+ cd integer NOT NULL,
+ producer integer NOT NULL,
+ PRIMARY KEY (cd, producer)
);
--
);
--
--- Table: cd_to_producer
---
-CREATE TABLE cd_to_producer (
- cd integer NOT NULL,
- producer integer NOT NULL,
- PRIMARY KEY (cd, producer)
-);
-
---
-- Table: artist
--
CREATE TABLE artist (
);
--
--- Table: tags
---
-CREATE TABLE tags (
- tagid INTEGER PRIMARY KEY NOT NULL,
- cd integer NOT NULL,
- tag varchar(100) NOT NULL
-);
-
---
-- Table: treelike
--
CREATE TABLE treelike (
);
--
--- Table: twokeys
+-- Table: tags
--
-CREATE TABLE twokeys (
- artist integer NOT NULL,
+CREATE TABLE tags (
+ tagid INTEGER PRIMARY KEY NOT NULL,
cd integer NOT NULL,
- PRIMARY KEY (artist, cd)
+ tag varchar(100) NOT NULL
);
--
--- Table: employees_positional
+-- Table: twokeys
--
-CREATE TABLE employees_positional (
- employee_id INTEGER PRIMARY KEY NOT NULL,
- position integer NOT NULL,
- group_id integer,
- name varchar(100)
+CREATE TABLE twokeys (
+ artist integer NOT NULL,
+ cd integer NOT NULL,
+ PRIMARY KEY (artist, cd)
);
--
+++ /dev/null
-# vim: filetype=perl
-
-sub run_tests {
-
- plan tests => 5;
- my $schema = shift;
-
- my $employees = $schema->resultset('Employee::AdjacencyList');
- $employees->delete();
-
- my $grandma = $employees->create({ name=>'grandma', parent_id=>0 });
- foreach (1..15) {
- $employees->create({ name=>'temp', parent_id=>$grandma->id() });
- }
- ok( ($grandma->children->count()==15), 'grandma children' );
-
- my $mom = ($grandma->children->search(undef,{rows=>1})->all())[0];
- foreach (1..5) {
- ($grandma->children->search(undef,{rows=>1})->all())[0]->parent( $mom );
- }
- ok( ($mom->children->count()==5), 'mom children' );
- ok( ($grandma->children->count()==10), 'grandma children' );
-
- $mom = ($grandma->children->search(undef,{rows=>2})->all())[0];
- foreach (1..4) {
- ($grandma->children->search(undef,{rows=>1})->all())[0]->parent( $mom );
- }
- ok( ($mom->children->count()==4), 'mom children' );
- ok( ($grandma->children->count()==6), 'grandma children' );
-
- ok( check_rs( scalar $grandma->children() ), 'correct positions' );
-}
-
-sub check_rs {
- my( $rs ) = @_;
- $rs->reset();
- my $position_column = $rs->result_class->position_column();
- my $expected_position = 0;
- while (my $row = $rs->next()) {
- $expected_position ++;
- if ($row->get_column($position_column)!=$expected_position) {
- return 0;
- }
- my $children = $row->children();
- while (my $child = $children->next()) {
- return 0 if (!check_rs( scalar $child->children() ));
- }
- }
- return 1;
-}
-
-1;
projects / dbsrgits/DBIx-Class.git / commitdiff