The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -T

# t/99data.t
#  Test data constraints of the SQLite database
#
# $Id: 99data.t 8192 2009-07-24 22:39:15Z FREQUENCY@cpan.org $

use strict;
use warnings;

use Test::More;

use File::Spec;

unless ($ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING}) {
  plan skip_all => 'Author tests not required for installation';
}

my %MODULES = (
  'DBI'           => 0,
  'DBD::SQLite'   => 0,
);

while (my ($module, $version) = each %MODULES) {
  eval "use $module $version";
  next unless $@;

  if ($ENV{RELEASE_TESTING}) {
    die 'Could not load release-testing module ' . $module;
  }
  else {
    plan skip_all => $module . ' not available for testing';
  }
}

# Find the codec database, relative to the main dist dir
my $data = File::Spec->catfile(
  'lib',
  'Video',
  'FourCC',
  #'Info.pm', # same directory, different filename :-)
  'codecs.dat'
);

# Open the database
my $dbh = DBI->connect(
  'dbi:SQLite:dbname=' . $data,
  'notused', # cannot be null, or DBI complains
  'notused',
  {
    RaiseError => 1,
    AutoCommit => 1,
    PrintError => 0,
  }
);

my $rowcount;

# Get the number of rows in our database
{
  my $sth = $dbh->prepare('SELECT COUNT(*) FROM fourcc');
  $sth->execute();
  ($rowcount) = $sth->fetchrow_array();
}

# Set up one test per row
plan tests => $rowcount;

# Check database constraints.  This is a pretty heavy test, since it needs
# to probe each row, which is why this is set as an author test :-)
my $sth = $dbh->prepare('SELECT * FROM fourcc');
$sth->execute();

my $row = 1;

# Grab the first and only array element; this is the FourCC
while (defined (my $href = $sth->fetchrow_hashref())) {
  my $ok = 1;

  # Each FourCC must be:
  # - Defined
  # - Four characters long (space-padded if necessary)
  # - Uppercased
  if (!exists $href->{fourcc}) {
    diag('Found NULL FourCC in database');
    $ok = 0;
    next;
  }

  my $code = $href->{fourcc};
  if (length $code != 4) {
    diag('FourCC "', $code, '" is ', length $code, ' bytes! (should be 4)');
    $ok = 0;
  }

  if ($code ne uc($code)) {
    diag('FourCC "', $code, '" is not uppercase');
    $ok = 0;
  }

  # Each owner name must be:
  # - Without leading or trailing spaces
  if (defined $href->{owner}) {
    if ($href->{owner} =~ /^\s+/s) {
      diag('Owner data of FourCC "', $code, '" has leading spaces');
      $ok = 0;
    }
    if ($href->{owner} =~ /\s+$/s) {
      diag('Owner data of FourCC "', $code, '" has trailing spaces');
      $ok = 0;
    }
  }

  # Each date must be:
  # - In yyyy-mm-dd format
  if (defined $href->{registered}) {
    if ($href->{registered} !~ /^\d{4}-\d{2}-\d{2}/s) {
      diag('Registration date of FourCC "', $code, '" is invalid');
      $ok = 0;
    }
  }

  # Each description must be:
  # - Defined (not NULL)
  # - Without leading or trailing spaces
  if (defined $href->{description}) {
    if ($href->{description} =~ /^\s+/s) {
      diag('Description of FourCC "', $code, '" has leading spaces');
      $ok = 0;
    }
    if ($href->{description} =~ /\s+$/s) {
      diag('Description of FourCC "', $code, '" has trailing spaces');
      $ok = 0;
    }
  }
  else {
    diag('Description of FourCC "', $code, '" is NULL!');
    $ok = 0;
  }

  ok($ok, 'Database values appear sane for row ' . $row);
  $row++;
}