1 package DBIx::Class::Version::Table;
2 use base 'DBIx::Class';
6 __PACKAGE__->load_components(qw/ Core/);
7 __PACKAGE__->table('dbix_class_schema_versions');
9 __PACKAGE__->add_columns
11 'data_type' => 'VARCHAR',
12 'is_auto_increment' => 0,
13 'default_value' => undef,
14 'is_foreign_key' => 0,
20 'data_type' => 'VARCHAR',
21 'is_auto_increment' => 0,
22 'default_value' => undef,
23 'is_foreign_key' => 0,
24 'name' => 'Installed',
29 __PACKAGE__->set_primary_key('Version');
31 package DBIx::Class::Version::TableCompat;
32 use base 'DBIx::Class::Version::Table';
34 __PACKAGE__->table('SchemaVersions');
36 package DBIx::Class::Version;
37 use base 'DBIx::Class::Schema';
41 __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
43 package DBIx::Class::VersionCompat;
44 use base 'DBIx::Class::Schema';
48 __PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
51 # ---------------------------------------------------------------------------
55 DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
59 package Library::Schema;
60 use base qw/DBIx::Class::Schema/;
61 # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
62 __PACKAGE__->load_classes(qw/CD Book DVD/);
64 __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
65 __PACKAGE__->upgrade_directory('/path/to/upgrades/');
66 __PACKAGE__->backup_directory('/path/to/backups/');
71 This module is a component designed to extend L<DBIx::Class::Schema>
72 classes, to enable them to upgrade to newer schema layouts. To use this
73 module, you need to have called C<create_ddl_dir> on your Schema to
74 create your upgrade files to include with your delivery.
76 A table called I<dbix_class_schema_versions> is created and maintained by the
77 module. This contains two fields, 'Version' and 'Installed', which
78 contain each VERSION of your Schema, and the date+time it was installed.
80 The actual upgrade is called manually by calling C<upgrade> on your
81 schema object. Code is run at connect time to determine whether an
82 upgrade is needed, if so, a warning "Versions out of sync" is
85 So you'll probably want to write a script which generates your DDLs and diffs
86 and another which executes the upgrade.
88 NB: At the moment, only SQLite and MySQL are supported. This is due to
89 spotty behaviour in the SQL::Translator producers, please help us by
94 =head2 upgrade_directory
96 Use this to set the directory your upgrade files are stored in.
98 =head2 backup_directory
100 Use this to set the directory you want your backups stored in.
104 package DBIx::Class::Schema::Versioned;
108 use base 'DBIx::Class';
109 use POSIX 'strftime';
112 __PACKAGE__->mk_classdata('_filedata');
113 __PACKAGE__->mk_classdata('upgrade_directory');
114 __PACKAGE__->mk_classdata('backup_directory');
115 __PACKAGE__->mk_classdata('do_backup');
116 __PACKAGE__->mk_classdata('do_diff_on_init');
118 =head2 schema_version
120 Returns the current schema class' $VERSION; does -not- use $schema->VERSION
121 since that varies in results depending on if version.pm is installed, and if
122 so the perl or XS versions. If you want this to change, bug the version.pm
123 author to make vpp and vxs behave the same.
129 my $class = ref($self)||$self;
133 $version = ${"${class}::VERSION"};
138 =head2 get_db_version
140 Returns the version that your database is currently at. This is determined by the values in the
141 dbix_class_schema_versions table that $self->upgrade writes to.
147 my ($self, $rs) = @_;
149 my $vtable = $self->{vschema}->resultset('Table');
150 return 0 unless ($self->_source_exists($vtable));
152 my $psearch = $vtable->search(undef,
154 { 'max' => 'Installed' },
156 as => ['maxinstall'],
158 my $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
160 $pversion = $pversion->Version if($pversion);
166 my ($self, $rs) = @_;
169 $rs->search({ 1, 0 })->count;
171 return 0 if $@ || !defined $c;
178 This is an overwritable method which is called just before the upgrade, to
179 allow you to make a backup of the database. Per default this method attempts
180 to call C<< $self->storage->backup >>, to run the standard backup on each
183 This method should return the name of the backup file, if appropriate..
190 ## Make each ::DBI::Foo do this
191 $self->storage->backup($self->backup_directory());
194 # is this just a waste of time? if not then merge with DBI.pm
195 sub _create_db_to_schema_diff {
198 my %driver_to_db_map = (
202 my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
204 print "Sorry, this is an unsupported DB\n";
208 eval 'require SQL::Translator "0.09"';
210 $self->throw_exception("SQL::Translator 0.09 required");
213 my $db_tr = SQL::Translator->new({
216 parser_args => { dbh => $self->storage->dbh }
219 $db_tr->producer($db);
220 my $dbic_tr = SQL::Translator->new;
221 $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
222 $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
223 $dbic_tr->data($self);
224 $dbic_tr->producer($db);
226 $db_tr->schema->name('db_schema');
227 $dbic_tr->schema->name('dbic_schema');
229 # is this really necessary?
230 foreach my $tr ($db_tr, $dbic_tr) {
231 my $data = $tr->data;
232 $tr->parser->($tr, $$data);
235 my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
236 $dbic_tr->schema, $db,
237 { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
239 my $filename = $self->ddl_filename(
241 $self->upgrade_directory,
242 $self->schema_version,
246 if(!open($file, ">$filename"))
248 $self->throw_exception("Can't open $filename for writing ($!)");
254 print "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
259 Call this to attempt to upgrade your database from the version it is at to the version
260 this DBIC schema is at.
262 It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
263 have created this using $schema->create_ddl_dir.
270 my $db_version = $self->get_db_version();
273 unless ($db_version) {
274 # set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at
275 $self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
277 # create versions table and version row
278 $self->{vschema}->deploy;
279 $self->_set_db_version;
283 # db and schema at same version. do nothing
284 if ($db_version eq $self->schema_version) {
285 print "Upgrade not necessary\n";
289 # strangely the first time this is called can
290 # differ to subsequent times. so we call it
293 $self->storage->sqlt_type;
295 my $upgrade_file = $self->ddl_filename(
296 $self->storage->sqlt_type,
297 $self->upgrade_directory,
298 $self->schema_version,
302 unless (-f $upgrade_file) {
303 warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
307 # backup if necessary then apply upgrade
308 $self->_filedata($self->_read_sql_file($upgrade_file));
309 $self->backup() if($self->do_backup);
310 $self->txn_do(sub { $self->do_upgrade() });
312 # set row in dbix_class_schema_versions table
313 $self->_set_db_version;
316 sub _set_db_version {
319 my $vtable = $self->{vschema}->resultset('Table');
320 $vtable->create({ Version => $self->schema_version,
321 Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
328 my $file = shift || return;
331 open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
332 my @data = split(/\n/, join('', <$fh>));
333 @data = grep(!/^--/, @data);
334 @data = split(/;/, join('', @data));
336 @data = grep { $_ && $_ !~ /^-- / } @data;
337 @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
343 This is an overwritable method used to run your upgrade. The freeform method
344 allows you to run your upgrade any way you please, you can call C<run_upgrade>
345 any number of times to run the actual SQL commands, and in between you can
346 sandwich your data upgrading. For example, first run all the B<CREATE>
347 commands, then migrate your data from old to new tables/formats, then
348 issue the DROP commands when you are finished.
350 Will run the whole file as it is by default.
358 ## overridable sub, per default just run all the commands.
359 $self->run_upgrade(qr/create/i);
360 $self->run_upgrade(qr/alter table .*? add/i);
361 $self->run_upgrade(qr/alter table .*? (?!drop)/i);
362 $self->run_upgrade(qr/alter table .*? drop/i);
363 $self->run_upgrade(qr/drop/i);
368 $self->run_upgrade(qr/create/i);
370 Runs a set of SQL statements matching a passed in regular expression. The
371 idea is that this method can be called any number of times from your
372 C<upgrade> method, running whichever commands you specify via the
373 regex in the parameter. Probably won't work unless called from the overridable
380 my ($self, $stm) = @_;
382 return unless ($self->_filedata);
383 my @statements = grep { $_ =~ $stm } @{$self->_filedata};
384 $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
388 $self->storage->debugobj->query_start($_) if $self->storage->debug;
389 $self->storage->dbh->do($_) or warn "SQL was:\n $_";
390 $self->storage->debugobj->query_end($_) if $self->storage->debug;
398 $self->next::method(@_);
406 $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
407 my $vtable = $self->{vschema}->resultset('Table');
409 # check for legacy versions table and move to new if exists
410 my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
411 unless ($self->_source_exists($vtable)) {
412 my $vtable_compat = $vschema_compat->resultset('TableCompat');
413 if ($self->_source_exists($vtable_compat)) {
414 $self->{vschema}->deploy;
415 map { $vtable->create({$_->get_columns}) } $vtable_compat->all;
416 $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
420 my $pversion = $self->get_db_version();
422 if($pversion eq $self->schema_version)
424 warn "This version is already installed\n";
430 warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
434 warn "Versions out of sync. This is " . $self->schema_version .
435 ", your database contains version $pversion, please call upgrade on your Schema.\n";
443 Jess Robinson <castaway@desert-island.demon.co.uk>
444 Luke Saunders <luke@shadowcatsystems.co.uk>
448 You may distribute this code under the same terms as Perl itself.