[Bast-commits] r3371 - in trunk/DBIx-Class-InflateColumn-IP: .
lib/DBIx/Class/InflateColumn t t/lib t/lib/DBICTest
t/lib/DBICTest/Schema
ilmari at dev.catalyst.perl.org
ilmari at dev.catalyst.perl.org
Thu May 24 14:11:01 GMT 2007
Author: ilmari
Date: 2007-05-24 14:11:00 +0100 (Thu, 24 May 2007)
New Revision: 3371
Added:
trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Network.pm
trunk/DBIx-Class-InflateColumn-IP/t/style-notabs.t
Modified:
trunk/DBIx-Class-InflateColumn-IP/Changes
trunk/DBIx-Class-InflateColumn-IP/MANIFEST
trunk/DBIx-Class-InflateColumn-IP/README
trunk/DBIx-Class-InflateColumn-IP/lib/DBIx/Class/InflateColumn/IP.pm
trunk/DBIx-Class-InflateColumn-IP/t/01-ip.t
trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest.pm
trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema.pm
trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Host.pm
trunk/DBIx-Class-InflateColumn-IP/t/lib/sqlite.sql
Log:
Add configuration options for address format and class.
Modified: trunk/DBIx-Class-InflateColumn-IP/Changes
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/Changes 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/Changes 2007-05-24 13:11:00 UTC (rev 3371)
@@ -1,5 +1,8 @@
Revision history for DBIx::Class::InflateColumn::IP
+0.01001 Thu May 24 11:28:40 2007
+ - Added configuration options for format and class.
+
0.01 Wed May 23 14:53:10 2007
- First version, released on an unsuspecting world.
Modified: trunk/DBIx-Class-InflateColumn-IP/MANIFEST
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/MANIFEST 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/MANIFEST 2007-05-24 13:11:00 UTC (rev 3371)
@@ -22,6 +22,8 @@
t/lib/DBICTest.pm
t/lib/DBICTest/Schema.pm
t/lib/DBICTest/Schema/Host.pm
+t/lib/DBICTest/Schema/Network.pm
t/lib/sqlite.sql
t/pod-coverage.t
t/pod.t
+t/style-notabs.t
Modified: trunk/DBIx-Class-InflateColumn-IP/README
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/README 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/README 2007-05-24 13:11:00 UTC (rev 3371)
@@ -3,27 +3,55 @@
columns.
VERSION
- Version 0.01
+ Version 0.01001
SYNOPSIS
- Load this component and declare integer columns as IP addresses.
+ Load this component and declare columns as IP addresses with the
+ appropriate format.
package Host;
- __PACKAGE__->load_components(qw/InflateColumn::IP/);
+ __PACKAGE__->load_components(qw/InflateColumn::IP Core/);
__PACKAGE__->add_columns(
ip_address => {
data_type => 'integer',
is_nullable => 0,
is_ip => 1,
+ ip_format => 'numeric',
}
);
+ package Network;
+ __PACKAGE__->load_components(qw/InflateColumn::IP Core/);
+ __PACKAGE__->add_columns(
+ address => {
+ data_type => 'varchar',
+ size => 18
+ is_nullable => 0,
+ is_ip => 1,
+ ip_format => 'cidr',
+ }
+ );
+
Then you can treat the specified column as a NetAddr::IP object.
- print 'IP address: ', $host->ip_address->ip;
+ print 'IP address: ', $host->ip_address->addr;
print 'Address type: ', $host->ip_address->iptype;
METHODS
+ ip_class
+ Arguments: $class
+
+ Gets/sets the address class that the columns should be inflated into.
+ The default class is NetAddr::IP.
+
+ ip_format
+ Arguments: $format
+
+ Gets/sets the name of the method used to deflate the address for the
+ database. This must return a value suitable for "$ip_class-"new(); The
+ default format is "addr", which returns the address in dotted-quad
+ notation. See "Methods" in NetAddr::IP for suitable values.
+
register_column
Chains with "register_column" in DBIx::Class::Row, and sets up IP
address columns appropriately. This would not normally be called
Modified: trunk/DBIx-Class-InflateColumn-IP/lib/DBIx/Class/InflateColumn/IP.pm
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/lib/DBIx/Class/InflateColumn/IP.pm 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/lib/DBIx/Class/InflateColumn/IP.pm 2007-05-24 13:11:00 UTC (rev 3371)
@@ -2,41 +2,83 @@
use warnings;
use strict;
-use NetAddr::IP;
+our $VERSION = '0.01001';
+
+use base qw/DBIx::Class/;
+__PACKAGE__->mk_classdata('ip_format');
+__PACKAGE__->mk_classdata('ip_class');
+
+__PACKAGE__->ip_format('addr');
+__PACKAGE__->ip_class('NetAddr::IP');
+
=head1 NAME
DBIx::Class::InflateColumn::IP - Auto-create NetAddr::IP objects from columns.
=head1 VERSION
-Version 0.01
+Version 0.01001
-=cut
-
-our $VERSION = '0.01';
-
=head1 SYNOPSIS
-Load this component and declare integer columns as IP addresses.
+Load this component and declare columns as IP addresses with the
+appropriate format.
package Host;
- __PACKAGE__->load_components(qw/InflateColumn::IP/);
+ __PACKAGE__->load_components(qw/InflateColumn::IP Core/);
__PACKAGE__->add_columns(
ip_address => {
data_type => 'integer',
is_nullable => 0,
is_ip => 1,
+ ip_format => 'numeric',
}
);
+ package Network;
+ __PACKAGE__->load_components(qw/InflateColumn::IP Core/);
+ __PACKAGE__->add_columns(
+ address => {
+ data_type => 'varchar',
+ size => 18
+ is_nullable => 0,
+ is_ip => 1,
+ ip_format => 'cidr',
+ }
+ );
+
Then you can treat the specified column as a NetAddr::IP object.
- print 'IP address: ', $host->ip_address->ip;
+ print 'IP address: ', $host->ip_address->addr;
print 'Address type: ', $host->ip_address->iptype;
=head1 METHODS
+=head2 ip_class
+
+=over
+
+=item Arguments: $class
+
+=back
+
+Gets/sets the address class that the columns should be inflated into.
+The default class is NetAddr::IP.
+
+=head2 ip_format
+
+=over
+
+=item Arguments: $format
+
+=back
+
+Gets/sets the name of the method used to deflate the address for the
+database. This must return a value suitable for C<$ip_class->new(); The
+default format is C<addr>, which returns the address in dotted-quad
+notation. See L<NetAddr::IP/Methods> for suitable values.
+
=head2 register_column
Chains with L<DBIx::Class::Row/register_column>, and sets up IP address
@@ -51,10 +93,18 @@
return unless defined $info->{'is_ip'};
+ my $ip_format = $info->{ip_format} || $self->ip_format || 'addr';
+ my $ip_class = $info->{ip_class} || $self->ip_class || 'NetAddr::IPf';
+
+ eval "use $ip_class";
+ $self->throw_exception("Error loading $ip_class: $@") if $@;
+ $self->throw_exception("Format '$ip_format' not supported by $ip_class")
+ unless $ip_class->can($ip_format);
+
$self->inflate_column(
$column => {
- inflate => sub { return NetAddr::IP->new(shift); },
- deflate => sub { return scalar shift->numeric; },
+ inflate => sub { return $ip_class->new(shift); },
+ deflate => sub { return scalar shift->$ip_format; },
}
);
}
Modified: trunk/DBIx-Class-InflateColumn-IP/t/01-ip.t
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/t/01-ip.t 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/t/01-ip.t 2007-05-24 13:11:00 UTC (rev 3371)
@@ -1,7 +1,7 @@
-#!perl -T
+#!perl -T
use lib qw(t/lib);
use DBICTest;
-use Test::More tests => 6;
+use Test::More tests => 10;
use NetAddr::IP;
my $schema = DBICTest->init_schema();
@@ -10,13 +10,13 @@
my $localhost = $host_rs->find('localhost');
-isa_ok($localhost->ip, 'NetAddr::IP', 'inflated to right class');
-is($localhost->ip, '127.0.0.1/32', 'address correctly inflated');
+isa_ok($localhost->address, 'NetAddr::IP', 'numeric address inflated to right class');
+is($localhost->address, '127.0.0.1/32', 'numeric address correctly inflated');
TODO: {
- local $TODO = "find by object doesn't work yet";
+ local $TODO = "DBIx::Class doesn't support find by object yet";
- $localhost = $host_rs->find(NetAddr::IP->new('127.0.0.1'), { key => 'ip' });
+ $localhost = $host_rs->find(NetAddr::IP->new('127.0.0.1'), { key => 'address' });
ok($localhost, 'find by object returned a row');
}
@@ -24,11 +24,24 @@
SKIP: {
skip 'no object to check' => 1 unless $localhost;
- is($localhost->hostname, 'localhost', 'right row found by object');
+ is($localhost->hostname, 'localhost', 'find by object returned the right row');
}
my $ip = NetAddr::IP->new('192.168.0.1');
-my $host = $host_rs->create({ hostname => 'foo', ip => $ip });
+my $host = $host_rs->create({ hostname => 'foo', address => $ip });
isa_ok($host, 'DBICTest::Schema::Host', 'create with object');
-is($host->get_column('ip'), $ip->numeric, 'address correctly deflated');
+is($host->get_column('address'), $ip->numeric, 'numeric address correctly deflated');
+
+my $net_rs = $schema->resultset('Network');
+
+my $localnet = $net_rs->find('localnet');
+
+isa_ok($localnet->address, 'NetAddr::IP', 'CIDR address inflated to right class');
+is($localnet->address, '127.0.0.0/8', 'CIDR address correctly inflated');
+
+my $net_ip = NetAddr::IP->new('192.168.0.42/24');
+my $net = $net_rs->create({ netname => 'foo', address => $net_ip });
+
+isa_ok($net, 'DBICTest::Schema::Network', 'create with object');
+is($net->get_column('address'), '192.168.0.42/24', 'CIDR address correctly deflated');
Modified: trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Host.pm
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Host.pm 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Host.pm 2007-05-24 13:11:00 UTC (rev 3371)
@@ -11,14 +11,15 @@
data_type => 'text',
is_nullable => 0,
},
- ip => {
+ address => {
data_type => 'integer',
is_nullable => 0,
is_ip => 1,
+ ip_format => 'numeric',
}
);
__PACKAGE__->set_primary_key('hostname');
-__PACKAGE__->add_unique_constraint(ip => [ qw/ip/ ]);
+__PACKAGE__->add_unique_constraint(address => [ qw/address/ ]);
1;
Added: trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Network.pm
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Network.pm (rev 0)
+++ trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema/Network.pm 2007-05-24 13:11:00 UTC (rev 3371)
@@ -0,0 +1,26 @@
+package # hide from PAUSE
+ DBICTest::Schema::Network;
+
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/InflateColumn::IP Core/);
+__PACKAGE__->table('network');
+
+__PACKAGE__->add_columns(
+ netname => {
+ data_type => 'text',
+ is_nullable => 0,
+ },
+ address => {
+ data_type => 'varchar',
+ size => '18',
+ is_nullable => 0,
+ is_ip => 1,
+ ip_format => 'cidr',
+ }
+);
+
+__PACKAGE__->set_primary_key('netname');
+__PACKAGE__->add_unique_constraint(address => [ qw/address/ ]);
+
+1;
Modified: trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema.pm
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema.pm 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest/Schema.pm 2007-05-24 13:11:00 UTC (rev 3371)
@@ -3,6 +3,6 @@
use base qw/DBIx::Class::Schema/;
-__PACKAGE__->load_classes(qw/Host/);
+__PACKAGE__->load_classes();
1;
Modified: trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest.pm
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest.pm 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/t/lib/DBICTest.pm 2007-05-24 13:11:00 UTC (rev 3371)
@@ -105,9 +105,14 @@
my $schema = shift;
$schema->populate('Host', [
- [ qw/hostname ip/ ],
+ [ qw/hostname address/ ],
[ 'localhost', 2130706433 ],
]);
+
+ $schema->populate('Network', [
+ [ qw/netname address/ ],
+ [ qw{localnet 127.0.0.0/8} ],
+ ]);
}
1;
Modified: trunk/DBIx-Class-InflateColumn-IP/t/lib/sqlite.sql
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/t/lib/sqlite.sql 2007-05-24 02:26:03 UTC (rev 3370)
+++ trunk/DBIx-Class-InflateColumn-IP/t/lib/sqlite.sql 2007-05-24 13:11:00 UTC (rev 3371)
@@ -1,4 +1,9 @@
CREATE TABLE host (
hostname TEXT NOT NULL PRIMARY KEY,
- ip INTEGER NOT NULL UNIQUE
+ address INTEGER NOT NULL UNIQUE
);
+
+CREATE TABLE network (
+ netname TEXT NOT NULL PRIMARY KEY,
+ address VARCHAR(18) NOT NULL UNIQUE
+);
Added: trunk/DBIx-Class-InflateColumn-IP/t/style-notabs.t
===================================================================
--- trunk/DBIx-Class-InflateColumn-IP/t/style-notabs.t (rev 0)
+++ trunk/DBIx-Class-InflateColumn-IP/t/style-notabs.t 2007-05-24 13:11:00 UTC (rev 3371)
@@ -0,0 +1,20 @@
+#!perl -T
+use strict;
+use warnings;
+
+use Test::More;
+
+if (not $ENV{TEST_AUTHOR}) {
+ plan skip_all => 'set TEST_AUTHOR to enable this test';
+}
+else {
+ eval 'use Test::NoTabs 0.03';
+ if ($@) {
+ plan skip_all => 'Test::NoTabs 0.03 not installed';
+ }
+ else {
+ plan tests => 1;
+ }
+}
+
+all_perl_files_ok('lib');
More information about the Bast-commits
mailing list