/usr/share/perl5/Pinto/Database.pm is in pinto 0.97+dfsg-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | # ABSTRACT: Interface to the Pinto database
package Pinto::Database;
use Moose;
use MooseX::StrictConstructor;
use MooseX::ClassAttribute;
use MooseX::MarkAsMethods ( autoclean => 1 );
use MooseX::Types::Moose qw(Str);
use Path::Class qw(file);
use Pinto::Schema;
use Pinto::Types qw(File);
use Pinto::Util qw(debug throw);
#-------------------------------------------------------------------------------
our $VERSION = '0.097'; # VERSION
#-------------------------------------------------------------------------------
has repo => (
is => 'ro',
isa => 'Pinto::Repository',
weak_ref => 1,
required => 1,
);
has schema => (
is => 'ro',
isa => 'Pinto::Schema',
builder => '_build_schema',
init_arg => undef,
lazy => 1,
);
class_has ddl => (
is => 'ro',
isa => Str,
init_arg => undef,
default => do { local $/ = undef; <DATA> },
lazy => 1,
);
#-------------------------------------------------------------------------------
sub _build_schema {
my ($self) = @_;
my $schema = Pinto::Schema->new;
my $db_file = $self->repo->config->db_file;
my $dsn = "dbi:SQLite:$db_file";
my $xtra = { on_connect_call => 'use_foreign_keys' };
my @args = ( $dsn, undef, undef, $xtra );
my $connected = $schema->connect(@args);
# Inject attributes thru back door
$connected->repo( $self->repo );
# Tune sqlite (taken from monotone)...
my $dbh = $connected->storage->dbh;
$dbh->do('PRAGMA page_size = 8192');
$dbh->do('PRAGMA cache_size = 4000');
# These may be unhelpful or unwise...
#$dbh->do('PRAGMA temp_store = MEMORY');
#$dbh->do('PRAGMA journal_mode = WAL');
#$dbh->do('PRAGMA synchronous = OFF');
return $connected;
}
#-------------------------------------------------------------------------------
# NB: We used to just let DBIx::Class generate the DDL from its own schema, but
# SQL::Translator does not support the COLLATE feature of SQLite. So now, we
# ship Pinto with a real copy of the DDL, and feed it into the database when
# the repository is initialized.
#
# Personally, I kinda prefer having a raw DDL file, rather than generating it
# because then I know *exactly* what the database schema will be, and we are
# no longer exposed to bugs that might exist in SQL::Translator. We don't need
# to deploy to different RDBMSes, so we don't really need SQL::Translator to
# help with that anyway.
#
# DBD::SQLite can only process one statement at a time, so we have to parse
# the file and "do" each statement separately. Splitting on semicolons is
# primitive, but effective (as long as semicolons are only used in statement
# terminators).
#-------------------------------------------------------------------------------
sub deploy {
my ($self) = @_;
my $db_dir = $self->repo->config->db_dir;
debug("Makding db directory at $db_dir");
$db_dir->mkpath;
my $guard = $self->schema->storage->txn_scope_guard;
$self->create_database_schema;
$self->create_root_revision;
$guard->commit;
return $self;
}
#-------------------------------------------------------------------------------
sub create_database_schema {
my ($self) = @_;
debug("Creating database schema");
my $dbh = $self->schema->storage->dbh;
$dbh->do("$_;") for split /;/, $self->ddl;
return $self;
}
#-------------------------------------------------------------------------------
sub create_root_revision {
my ($self) = @_;
my $attrs = {
uuid => $self->root_revision_uuid,
message => 'root commit',
is_committed => 1
};
debug("Creating root revision");
return $self->schema->create_revision($attrs);
}
#-------------------------------------------------------------------------------
sub get_root_revision {
my ($self) = @_;
my $where = { uuid => $self->root_revision_uuid };
my $attrs = { key => 'uuid_unique' };
my $revision = $self->schema->find_revision( $where, $attrs )
or throw "PANIC: No root revision was found";
return $revision;
}
#-------------------------------------------------------------------------------
sub root_revision_uuid { return '00000000-0000-0000-0000-000000000000' }
#-------------------------------------------------------------------------------
__PACKAGE__->meta->make_immutable;
#-------------------------------------------------------------------------------
1;
=pod
=encoding UTF-8
=for :stopwords Jeffrey Ryan Thalhammer
=head1 NAME
Pinto::Database - Interface to the Pinto database
=head1 VERSION
version 0.097
=head1 AUTHOR
Jeffrey Ryan Thalhammer <jeff@stratopan.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Jeffrey Ryan Thalhammer.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__DATA__
CREATE TABLE distribution (
id INTEGER PRIMARY KEY NOT NULL,
author TEXT NOT NULL COLLATE NOCASE,
archive TEXT NOT NULL,
source TEXT NOT NULL,
mtime INTEGER NOT NULL,
sha256 TEXT NOT NULL,
md5 TEXT NOT NULL,
metadata TEXT NOT NULL,
UNIQUE(author, archive)
);
CREATE TABLE package (
id INTEGER PRIMARY KEY NOT NULL,
name TEXT NOT NULL,
version TEXT NOT NULL,
file TEXT DEFAULT NULL,
sha256 TEXT DEFAULT NULL,
distribution INTEGER NOT NULL REFERENCES distribution(id) ON DELETE CASCADE,
UNIQUE(name, distribution)
);
CREATE TABLE stack (
id INTEGER PRIMARY KEY NOT NULL,
name TEXT NOT NULL UNIQUE COLLATE NOCASE,
is_default BOOLEAN NOT NULL,
is_locked BOOLEAN NOT NULL,
properties TEXT NOT NULL,
head INTEGER NOT NULL REFERENCES revision(id) ON DELETE RESTRICT
);
CREATE TABLE registration (
id INTEGER PRIMARY KEY NOT NULL,
revision INTEGER NOT NULL REFERENCES revision(id) ON DELETE CASCADE,
package_name TEXT NOT NULL,
package INTEGER NOT NULL REFERENCES package(id) ON DELETE CASCADE,
distribution INTEGER NOT NULL REFERENCES distribution(id) ON DELETE CASCADE,
is_pinned BOOLEAN NOT NULL,
UNIQUE(revision, package_name)
);
CREATE TABLE revision (
id INTEGER PRIMARY KEY NOT NULL,
uuid TEXT NOT NULL UNIQUE,
message TEXT NOT NULL,
username TEXT NOT NULL,
utc_time INTEGER NOT NULL,
time_offset INTEGER NOT NULL,
is_committed BOOLEAN NOT NULL,
has_changes BOOLEAN NOT NULL
);
CREATE TABLE ancestry (
id INTEGER PRIMARY KEY NOT NULL,
parent INTEGER NOT NULL REFERENCES revision(id) ON DELETE CASCADE,
child INTEGER NOT NULL REFERENCES revision(id) ON DELETE CASCADE
);
CREATE TABLE prerequisite (
id INTEGER PRIMARY KEY NOT NULL,
phase TEXT NOT NULL,
distribution INTEGER NOT NULL REFERENCES distribution(id) ON DELETE CASCADE,
package_name TEXT NOT NULL,
package_version TEXT NOT NULL,
UNIQUE(distribution, phase, package_name)
);
CREATE INDEX idx_ancestry_parent ON ancestry(parent);
CREATE INDEX idx_ancestry_child ON ancestry(child);
CREATE INDEX idx_package_sha256 ON package(sha256);
CREATE INDEX idx_distribution_sha256 ON distribution(sha256);
|