The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
package Pinwheel::Fixtures;

use strict;
use warnings;

use FindBin qw($Bin);
use File::Slurp;
use POSIX qw(strftime);
use YAML::Tiny;

use Pinwheel::Context;
use Pinwheel::Database qw(without_foreign_keys);
use Pinwheel::View::ERB;

our @ISA = qw(Exporter);
our @EXPORT = qw(fixtures scenario identify);
our @EXPORT_OK = qw(insert_fixtures empty_tables);


our $fixtures_path = "$Bin/../fixtures";
our $last_caller = '';
our $helpers;
my %ids;


sub fixtures
{
    my (@names) = @_;
    my ($caller) = caller();

    without_foreign_keys {
        if ($caller ne $last_caller) {
            empty_tables();
            $last_caller = $caller;
        }
        foreach my $table (@names) {
            insert_fixtures(_load_yaml("$fixtures_path/$table.yml"), $table);
        }
    };

    # For doctest niceness, otherwise the result is that of the commit
    return;
}

# See http://code.google.com/p/fixture-scenarios/
sub scenario
{
    my ($name, %opts) = @_;
    my (@dirs, $path);

    $last_caller = caller();
    $path = $fixtures_path;
    if (!exists($opts{'root'}) || $opts{'root'}) {
        push @dirs, $path;
    }
    foreach (split('/', $name)) {
        $path .= '/' . $_;
        push @dirs, $path;
    }

    without_foreign_keys {
        empty_tables();
        foreach $path (@dirs) {
            foreach (glob("$path/*.yml")) {
                /\/([^\/]+)\.yml$/;
                insert_fixtures(_load_yaml($_), $1);
            }
        }
    };

    # For doctest niceness, otherwise the result is that of the commit
    return;
}

sub empty_tables
{
    foreach my $table (Pinwheel::Database::tables()) {
        my $sth = Pinwheel::Database::prepare("DELETE FROM $table");
        $sth->execute();
    }
}

sub insert_fixtures
{
    my ($fixtures, $table) = @_;
    my ($sth, $info, %defaults, @keys);
    my ($label, $row, @fields, $columns, $values);

    $info = Pinwheel::Database::describe($table);
    foreach (keys %$info) {
        if ($_ =~ /^(?:cre|upd)ated_(?:at|on)$/) {
            # created_at/on and updated_at/on default to the current time
            $defaults{$_} = strftime('%Y-%m-%d %H:%M:%S', gmtime());
        } elsif ($_ =~ /_id$/ && $info->{$_}{type} =~ /^int\b/) {
            # Foreign keys can be supplied as labels
            push @keys, $_;
        }
    }

    $sth = {};
    while (($label, $row) = each(%$fixtures)) {
        $row = {%defaults, %$row};

        # If no id, generate one by hashing the label
        if (exists($info->{id}) && !exists($row->{id})) {
            $row->{id} = identify($label);
        }
        # Convert foreign keys supplied as labels
        foreach (@keys) {
            if ($row->{$_} && $row->{$_} =~ /[^0-9]/) {
                $row->{$_} = identify($row->{$_});
            }
        }

        @fields = keys %$row;
        $columns = join(', ', map { "`$_`" } @fields);
        unless ($sth->{$columns}) {
            $values = join(', ', ('?') x scalar(@fields));
            $sth->{$columns} = Pinwheel::Database::prepare(
                "REPLACE INTO $table ($columns) VALUES ($values)"
            );
        }
        $sth->{$columns}->execute(@{$row}{@fields});
    }
}

sub _load_yaml
{
    my ($filename) = @_;
    my ($data, $tmpl);

    $data = read_file($filename, binmode => ':raw');
    if ($data =~ /<%/) {
        _prepare_helpers() unless $helpers;
        $tmpl = Pinwheel::View::ERB::parse_template($data, $filename);
        $data = $tmpl->({}, {}, $helpers);
    }
    return YAML::Tiny->read_string($data)->[0];
}

sub _prepare_helpers
{
    my ($pkg, $fns);

    $fns = {};
    $pkg = \%Pinwheel::Helpers::Fixtures::;
    foreach (@{$pkg->{'EXPORT_OK'}}) {
        $fns->{$_} = \&{$pkg->{$_}} if $pkg->{$_};
    }

    $helpers = $fns;
}


sub identify
{
    my ($s) = @_;

    $ids{$s} = _hash($s) if !exists($ids{$s});
    return $ids{$s};
}


# Implementation of http://burtleburtle.net/bob/hash/evahash.html
sub _hash
{
    use integer;
    my ($s) = @_;
    my ($length, $a, $b, $c, $i, $j, @k);

    $length = length($s);
    $s .= "\0\0\0\0\0\0\0\0\0\0\0\0";
    @k = unpack('V' x (length($s) >> 2), $s);

    $i = 0;
    $j = ($length >> 2) - 3;
    $a = $b = 0x9e3779b9;
    $c = 0;
    while ($i <= $j) {
        $a += $k[$i++];
        $b += $k[$i++];
        $c += $k[$i++];
        ($a, $b, $c) = _mix($a, $b, $c);
    }

    $a += $k[$i++];
    $b += $k[$i++];
    $c += $length + ($k[$i++] << 8);
    ($a, $b, $c) = _mix($a, $b, $c);

    if ($c & 0x80000000) {
        $c = 0x80000000 - ($c & 0x7fffffff);
    } else {
        $c &= 0x7fffffff;
    }

    return $c;
}

sub _mix
{
    use integer;
    my ($a, $b, $c) = @_;

    $a = ($a - $b - $c) ^ (($c >> 13) & 0x0007ffff);
    $b = ($b - $c - $a) ^  ($a <<  8);
    $c = ($c - $a - $b) ^ (($b >> 13) & 0x0007ffff);
    $a = ($a - $b - $c) ^ (($c >> 12) & 0x000fffff);
    $b = ($b - $c - $a) ^  ($a << 16);
    $c = ($c - $a - $b) ^ (($b >>  5) & 0x07ffffff);
    $a = ($a - $b - $c) ^ (($c >>  3) & 0x1fffffff);
    $b = ($b - $c - $a) ^  ($a << 10);
    $c = ($c - $a - $b) ^ (($b >> 15) & 0x0001ffff);

    return ($a, $b, $c);
}


1;

__DATA__

=head1 NAME

Pinwheel::Fixtures

=head1 SYNOPSIS

    use Pinwheel::Fixtures;
    fixtures('episodes', 'brands', 'series', 'networks');
    scenario('radio4_empty_schedule');

The episodes.yml file might resemble:

    radio4:
      id: 1
      name: When Frogs Go Berserk
      short_description: This is the short description
      long_description: This is the long description of the episode
      pid: pid001
      series_id: 1
      position: 1

=head1 DESCRIPTION

Pinwheel::Fixtures provides a mechanism for loading YAML files into the database.
Database access is via the C<Pinwheel::Database> module.

The convention is the same as in Rails: the name of the YAML file is the name
of the database table.  The first element in the YAML is an identifier for the
tuple.  Each item for the tuple should be a row in the database using its
field name.

=head1 ROUTINES

=over 4

=item fixtures(NAMES)

TODO, properly document me.

This method is called to import the fixture data for the database tables
specified as a list of fieldnames.

=item scenario(NAME, OPTIONS)

TODO, properly document me.

Import a collection of fixtures in one go.  If called with an OPTIONS value of
C<< root => 0 >> then fixtures at the root of the fixture directory are
ignored.

=item $int = identify($string)

Hashes C<$string> to some integer.  This can be used to automatically pick IDs
that would normally be generated automatically by the database.

=item empty_tables()

Empties all the tables in the database.  (Specifically, uses C<DELETE> to do
so).

=item insert_fixtures($fixtures, $table)

Loads the data given by C<$fixtures> into the given database C<$table>.

Enumerates the columns in the given C<$table>.  Columns named
C<(created|updated)_(at|on)> are assigned a default of the current time.  Any
integer columns named like C<*_id> are deemed to be foreign keys.

For each C<$label, $row> in C<%$fixtures> (where C<$row> is a hash ref of
column name / value pairs):

=over 4

=item *

If the table has an 'id' column and there is no 'id' entry in C<$row>, the id
is filled in using C<identify($label)>.

=item *

For each column identified as a foreign key, if the value in C<$row> is
present but contains any non-digit characters, then the value is replaced by
C<identify($value)>.

=item *

The row is then written to the database (using REPLACE INTO).

=back

=back

=head1 EXPORTS

Exported by default: fixtures scenario identify

May be exported: insert_fixtures empty_tables

=head1 BUGS

The documentation doesn't describe how the fixtures are loaded, and how
'helpers' are used.  The synopsis mentions "the episodes.yaml" file, without
first mentioning that YAML is even used.

=head1 AUTHOR

A&M Network Publishing <DLAMNetPub@bbc.co.uk>

=cut