discard_changes is also "refresh from storage"
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Schema / Versioned.pm
CommitLineData
c9d2e0a2 1package DBIx::Class::Version::Table;
2use base 'DBIx::Class';
3use strict;
4use warnings;
5
6__PACKAGE__->load_components(qw/ Core/);
7__PACKAGE__->table('SchemaVersions');
8
9__PACKAGE__->add_columns
10 ( 'Version' => {
11 'data_type' => 'VARCHAR',
12 'is_auto_increment' => 0,
13 'default_value' => undef,
14 'is_foreign_key' => 0,
15 'name' => 'Version',
16 'is_nullable' => 0,
17 'size' => '10'
18 },
19 'Installed' => {
20 'data_type' => 'VARCHAR',
21 'is_auto_increment' => 0,
22 'default_value' => undef,
23 'is_foreign_key' => 0,
24 'name' => 'Installed',
25 'is_nullable' => 0,
26 'size' => '20'
27 },
28 );
29__PACKAGE__->set_primary_key('Version');
30
31package DBIx::Class::Version;
32use base 'DBIx::Class::Schema';
33use strict;
34use warnings;
35
36__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
37
38
39# ---------------------------------------------------------------------------
40package DBIx::Class::Schema::Versioned;
41
42use strict;
43use warnings;
44use base 'DBIx::Class';
45use POSIX 'strftime';
46use Data::Dumper;
47
48__PACKAGE__->mk_classdata('_filedata');
49__PACKAGE__->mk_classdata('upgrade_directory');
8795fefb 50__PACKAGE__->mk_classdata('backup_directory');
c9d2e0a2 51
42416a0b 52sub schema_version {
53 my ($self) = @_;
54 my $class = ref($self)||$self;
55 my $version;
56 {
57 no strict 'refs';
58 $version = ${"${class}::VERSION"};
59 }
60 return $version;
61}
62
a2800991 63sub connection {
64 my $self = shift;
65 $self->next::method(@_);
66 $self->_on_connect;
67 return $self;
68}
69
737416a4 70sub _on_connect
c9d2e0a2 71{
72 my ($self) = @_;
73 my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
74 my $vtable = $vschema->resultset('Table');
75 my $pversion;
e2c0df8e 76
a2800991 77 if(!$self->_source_exists($vtable))
c9d2e0a2 78 {
79# $vschema->storage->debug(1);
80 $vschema->storage->ensure_connected();
81 $vschema->deploy();
82 $pversion = 0;
83 }
84 else
85 {
86 my $psearch = $vtable->search(undef,
87 { select => [
88 { 'max' => 'Installed' },
89 ],
90 as => ['maxinstall'],
91 })->first;
92 $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
93 })->first;
94 $pversion = $pversion->Version if($pversion);
95 }
96# warn("Previous version: $pversion\n");
42416a0b 97 if($pversion eq $self->schema_version)
c9d2e0a2 98 {
99 warn "This version is already installed\n";
100 return 1;
101 }
102
103## use IC::DT?
104
105 if(!$pversion)
106 {
42416a0b 107 $vtable->create({ Version => $self->schema_version,
c9d2e0a2 108 Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
109 });
110 ## If we let the user do this, where does the Version table get updated?
111 warn "No previous version found, calling deploy to install this version.\n";
112 $self->deploy();
113 return 1;
114 }
115
116 my $file = $self->ddl_filename(
117 $self->storage->sqlt_type,
118 $self->upgrade_directory,
42416a0b 119 $self->schema_version
c9d2e0a2 120 );
121 if(!$file)
122 {
123 # No upgrade path between these two versions
124 return 1;
125 }
126
127 $file = $self->ddl_filename(
128 $self->storage->sqlt_type,
129 $self->upgrade_directory,
42416a0b 130 $self->schema_version,
c9d2e0a2 131 $pversion,
132 );
42416a0b 133# $file =~ s/@{[ $self->schema_version ]}/"${pversion}-" . $self->schema_version/e;
c9d2e0a2 134 if(!-f $file)
135 {
136 warn "Upgrade not possible, no upgrade file found ($file)\n";
137 return;
138 }
139
140 my $fh;
141 open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
142 my @data = split(/;\n/, join('', <$fh>));
143 close($fh);
144 @data = grep { $_ && $_ !~ /^-- / } @data;
145 @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
146
147 $self->_filedata(\@data);
148
149 ## Don't do this yet, do only on command?
150 ## If we do this later, where does the Version table get updated??
42416a0b 151 warn "Versions out of sync. This is " . $self->schema_version .
c9d2e0a2 152 ", your database contains version $pversion, please call upgrade on your Schema.\n";
42416a0b 153# $self->upgrade($pversion, $self->schema_version);
c9d2e0a2 154}
155
a2800991 156sub _source_exists
c9d2e0a2 157{
158 my ($self, $rs) = @_;
159
160 my $c = eval {
161 $rs->search({ 1, 0 })->count;
162 };
163 return 0 if $@ || !defined $c;
164
165 return 1;
166}
167
168sub backup
169{
170 my ($self) = @_;
171 ## Make each ::DBI::Foo do this
8795fefb 172 $self->storage->backup($self->backup_directory());
c9d2e0a2 173}
174
175sub upgrade
176{
177 my ($self) = @_;
178
179 ## overridable sub, per default just run all the commands.
180
181 $self->backup();
182
183 $self->run_upgrade(qr/create/i);
184 $self->run_upgrade(qr/alter table .*? add/i);
185 $self->run_upgrade(qr/alter table .*? (?!drop)/i);
186 $self->run_upgrade(qr/alter table .*? drop/i);
187 $self->run_upgrade(qr/drop/i);
188# $self->run_upgrade(qr//i);
189
190 my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
191 my $vtable = $vschema->resultset('Table');
42416a0b 192 $vtable->create({ Version => $self->schema_version,
c9d2e0a2 193 Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
194 });
195}
196
197
198sub run_upgrade
199{
200 my ($self, $stm) = @_;
201# print "Reg: $stm\n";
202 my @statements = grep { $_ =~ $stm } @{$self->_filedata};
203# print "Statements: ", join("\n", @statements), "\n";
204 $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
205
206 for (@statements)
207 {
70f39278 208 $self->storage->debugobj->query_start($_) if $self->storage->debug;
c9d2e0a2 209 $self->storage->dbh->do($_) or warn "SQL was:\n $_";
70f39278 210 $self->storage->debugobj->query_end($_) if $self->storage->debug;
c9d2e0a2 211 }
212
213 return 1;
214}
215
e2c0df8e 2161;
217
c9d2e0a2 218=head1 NAME
219
7d9fbacf 220DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
c9d2e0a2 221
222=head1 SYNOPSIS
223
224 package Library::Schema;
225 use base qw/DBIx::Class::Schema/;
226 # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
227 __PACKAGE__->load_classes(qw/CD Book DVD/);
228
229 __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
230 __PACKAGE__->upgrade_directory('/path/to/upgrades/');
8795fefb 231 __PACKAGE__->backup_directory('/path/to/backups/');
c9d2e0a2 232
233 sub backup
234 {
235 my ($self) = @_;
236 # my special backup process
237 }
238
239 sub upgrade
240 {
241 my ($self) = @_;
242
243 ## overridable sub, per default just runs all the commands.
244
245 $self->run_upgrade(qr/create/i);
246 $self->run_upgrade(qr/alter table .*? add/i);
247 $self->run_upgrade(qr/alter table .*? (?!drop)/i);
248 $self->run_upgrade(qr/alter table .*? drop/i);
249 $self->run_upgrade(qr/drop/i);
250 $self->run_upgrade(qr//i);
251 }
252
253=head1 DESCRIPTION
254
255This module is a component designed to extend L<DBIx::Class::Schema>
256classes, to enable them to upgrade to newer schema layouts. To use this
257module, you need to have called C<create_ddl_dir> on your Schema to
258create your upgrade files to include with your delivery.
259
260A table called I<SchemaVersions> is created and maintained by the
261module. This contains two fields, 'Version' and 'Installed', which
262contain each VERSION of your Schema, and the date+time it was installed.
263
264If you would like to influence which levels of version change need
265upgrades in your Schema, you can override the method C<ddl_filename>
266in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
267path between the two versions supplied. By default, every change in
268your VERSION is regarded as needing an upgrade.
269
8795fefb 270The actual upgrade is called manually by calling C<upgrade> on your
271schema object. Code is run at connect time to determine whether an
272upgrade is needed, if so, a warning "Versions out of sync" is
273produced.
274
c9d2e0a2 275NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
276returns SQL statements that SQLite does not support.
277
278
279=head1 METHODS
280
281=head2 backup
282
283This is an overwritable method which is called just before the upgrade, to
284allow you to make a backup of the database. Per default this method attempts
285to call C<< $self->storage->backup >>, to run the standard backup on each
286database type.
287
288This method should return the name of the backup file, if appropriate.
289
290C<backup> is called from C<upgrade>, make sure you call it, if you write your
291own <upgrade> method.
292
293=head2 upgrade
294
295This is an overwritable method used to run your upgrade. The freeform method
296allows you to run your upgrade any way you please, you can call C<run_upgrade>
297any number of times to run the actual SQL commands, and in between you can
298sandwich your data upgrading. For example, first run all the B<CREATE>
299commands, then migrate your data from old to new tables/formats, then
300issue the DROP commands when you are finished.
301
302=head2 run_upgrade
303
304 $self->run_upgrade(qr/create/i);
305
306Runs a set of SQL statements matching a passed in regular expression. The
307idea is that this method can be called any number of times from your
308C<upgrade> method, running whichever commands you specify via the
309regex in the parameter.
310
8795fefb 311=head2 upgrade_directory
312
313Use this to set the directory your upgrade files are stored in.
314
315=head2 backup_directory
316
317Use this to set the directory you want your backups stored in.
318
42416a0b 319=head2 schema_version
320
321Returns the current schema class' $VERSION; does -not- use $schema->VERSION
322since that varies in results depending on if version.pm is installed, and if
323so the perl or XS versions. If you want this to change, bug the version.pm
324author to make vpp and vxs behave the same.
325
c9d2e0a2 326=head1 AUTHOR
327
328Jess Robinson <castaway@desert-island.demon.co.uk>