view release on metacpan or  search on metacpan

t/plan.t  view on Meta::CPAN

    'v1.2_1',  # version number with underscore
) {
    # Test a change name.
    my $lines = encode_utf8 "\%project=foo\n\n$name $tsnp";
    my $fh = IO::File->new(\$lines, '<:utf8_strict');
    ok my $parsed = $plan->_parse('odditem', $fh),
        encode_utf8(qq{Should parse "$name"});
    cmp_deeply delete $parsed->{pragmas}, {
        syntax_version => App::Sqitch::Plan::SYNTAX_VERSION,
        project        => 'foo',
    }, encode_utf8("Should have captured the $name pragmas");
    cmp_deeply $parsed, {
        changes => [ clear, change { name => $name } ],
        lines => [ clear, version, $foo_proj, blank, change { name => $name } ],
    }, encode_utf8(qq{Should have pragmas in plan with change "$name"});

    # Test a tag name.
    my $tag = '@' . $name;
    $lines = encode_utf8 "\%project=foo\n\nfoo $tsnp\n$tag $tsnp";
    $fh = IO::File->new(\$lines, '<:utf8_strict');
    ok $parsed = $plan->_parse('gooditem', $fh),
        encode_utf8(qq{Should parse "$tag"});
    cmp_deeply delete $parsed->{pragmas}, {
        syntax_version => App::Sqitch::Plan::SYNTAX_VERSION,
        project        => 'foo',
    }, encode_utf8(qq{Should have pragmas in plan with tag "$name"});
    cmp_deeply $parsed, {
        changes => [ clear, change { name => 'foo' }, tag { name => $name } ],
        lines => [
            clear,
            version,
            $foo_proj,
            blank,
            change { name => 'foo' },
            tag { name => $name, ret => 1 }
        ],
    }, encode_utf8(qq{Should have line and change for "$tag"});
}
is sorted, 26, 'Should have sorted changes 26 times';

# Try planning with other reserved names.
for my $reserved (qw(HEAD ROOT)) {
    my $root = $prags . '@' . $reserved . " $tsnp";
    $file = file qw(t plans), "$reserved.plan";
    $fh = IO::File->new(\$root, '<:utf8_strict');
    throws_ok { $plan->_parse($file, $fh) } 'App::Sqitch::X',
        qq{Should die on plan with reserved tag "\@$reserved"};
    is $@->ident, 'parse', qq{\@$reserved exception should have ident "plan"};
    is $@->message, __x(
        'Syntax error in {file} at line {lineno}: {error}',
        file => $file,
        lineno => 4,
        error => __x(
            '"{name}" is a reserved name',
            name => '@' . $reserved,
        ),
    ), qq{And the \@$reserved error message should be correct};
    is sorted, 0, "Should have sorted \@$reserved changes nonce";
}

# Try a plan with a change name that looks like a sha1 hash.
my $sha1 = '6c2f28d125aff1deea615f8de774599acf39a7a1';
$file = file qw(t plans sha1.plan);
$fh = IO::File->new(\"$prags$sha1 $tsnp", '<:utf8_strict');
throws_ok { $plan->_parse($file, $fh) } 'App::Sqitch::X',
    'Should die on plan with SHA1 change name';
is $@->ident, 'parse', 'The SHA1 error ident should be "parse"';
is $@->message, __x(
    'Syntax error in {file} at line {lineno}: {error}',
    file => $file,
    lineno => 4,
    error => __x(
        '"{name}" is invalid because it could be confused with a SHA1 ID',
        name => $sha1,
    ),
), 'And the SHA1 error message should be correct';
is sorted, 0, 'Should have sorted changes nonce';

# Try a plan with a tag but no change.
$file = file qw(t plans tag-no-change.plan);
$fh = IO::File->new(\"$prags\@foo $tsnp\nbar $tsnp", '<:utf8_strict');
throws_ok { $plan->_parse($file, $fh) } 'App::Sqitch::X',
    'Should die on plan with tag but no preceding change';
is $@->ident, 'parse', 'The missing change error ident should be "parse"';
is $@->message, __x(
    'Syntax error in {file} at line {lineno}: {error}',
    file => $file,
    lineno => 4,
    error => __x(
        'Tag "{tag}" declared without a preceding change',
        tag => 'foo',
    ),
), 'And the missing change error message should be correct';
is sorted, 0, 'Should have sorted changes nonce';

# Try a plan with a duplicate tag name.
$file = file qw(t plans dupe-tag.plan);
$fh = $file->open('<:utf8_strict');
throws_ok { $plan->_parse($file, $fh) } 'App::Sqitch::X',
    'Should die on plan with dupe tag';
is $@->ident, 'parse', 'The dupe tag error ident should be "parse"';
is $@->message, __x(
    'Syntax error in {file} at line {lineno}: {error}',
    file => $file,
    lineno => 12,
    error => __x(
        'Tag "{tag}" duplicates earlier declaration on line {line}',
        tag  => 'bar',
        line => 7,
    ),
), 'And the missing change error message should be correct';
is sorted, 2, 'Should have sorted changes twice';

# Try a plan with a duplicate change within a tag section.
$file = file qw(t plans dupe-change.plan);
$fh = $file->open('<:utf8_strict');
throws_ok { $plan->_parse($file, $fh) } 'App::Sqitch::X',
    'Should die on plan with dupe change';
is $@->ident, 'parse', 'The dupe change error ident should be "parse"';
is $@->message, __x(
    'Syntax error in {file} at line {lineno}: {error}',

t/plan.t  view on Meta::CPAN

# Should choke on an invalid change names.
for my $name (@bad_names) {
    throws_ok { $plan->add( name => $name ) } 'App::Sqitch::X',
        qq{Should get error for invalid change "$name"};
    is $@->ident, 'plan', qq{Invalid name "$name" error ident should be "plan"};
    is $@->message, __x(
        qq{"{name}" is invalid: changes must not begin with punctuation, }
        . 'contain "@", ":", "#", "\\", "[", "]", or blanks, or end in punctuation or digits following punctuation',
        name => $name,
    ), qq{And the "$name" error message should be correct};
}

# Try a reserved name.
for my $reserved (qw(HEAD ROOT)) {
    throws_ok { $plan->add( name => $reserved ) } 'App::Sqitch::X',
        qq{Should get error for reserved name "$reserved"};
    is $@->ident, 'plan', qq{Reserved name "$reserved" error ident should be "plan"};
    is $@->message, __x(
        '"{name}" is a reserved name',
        name => $reserved,
    ), qq{And the reserved name "$reserved" message should be correct};
}

# Try an unknown dependency.
throws_ok { $plan->add( name => 'whu', requires => ['nonesuch' ] ) } 'App::Sqitch::X',
    'Should get failure for failed dependency';
is $@->ident, 'plan', 'Dependency error ident should be "plan"';
is $@->message, __x(
    'Cannot add change "{change}": requires unknown change "{req}"',
    change => 'whu',
    req    => 'nonesuch',
), 'The dependency error should be correct';

# Try invalid dependencies.
throws_ok { $plan->add( name => 'whu', requires => ['^bogus' ] ) } 'App::Sqitch::X',
    'Should get failure for invalid dependency';
is $@->ident, 'plan', 'Invalid dependency error ident should be "plan"';
is $@->message, __x(
    '"{dep}" is not a valid dependency specification',
    dep => '^bogus',
), 'The invalid dependency error should be correct';

throws_ok { $plan->add( name => 'whu', conflicts => ['^bogus' ] ) } 'App::Sqitch::X',
    'Should get failure for invalid conflict';
is $@->ident, 'plan', 'Invalid conflict error ident should be "plan"';
is $@->message, __x(
    '"{dep}" is not a valid dependency specification',
    dep => '^bogus',
), 'The invalid conflict error should be correct';

# Should choke on an unknown tag, too.
throws_ok { $plan->add(name => 'whu', requires => ['@nonesuch' ] ) } 'App::Sqitch::X',
    'Should get failure for failed tag dependency';
is $@->ident, 'plan', 'Tag dependency error ident should be "plan"';
is $@->message, __x(
    'Cannot add change "{change}": requires unknown change "{req}"',
    change => 'whu',
    req    => '@nonesuch',
), 'The tag dependency error should be correct';

# Should choke on a change that looks like a SHA1.
throws_ok { $plan->add(name => $sha1) } 'App::Sqitch::X',
    'Should get error for a SHA1 change';
is $@->ident, 'plan', 'SHA1 tag error ident should be "plan"';
is $@->message, __x(
    '"{name}" is invalid because it could be confused with a SHA1 ID',
    name => $sha1,,
), 'And the reserved name error should be output';

##############################################################################
# Try reworking a change.
can_ok $plan, 'rework';
ok my $rev_change = $plan->rework( name => 'you' ), 'Rework change "you"';
isa_ok $rev_change, 'App::Sqitch::Plan::Change';
is $rev_change->name, 'you', 'Reworked change should be "you"';
ok my $orig = $plan->change_at($plan->first_index_of('you')),
    'Get original "you" change';
is $orig->name, 'you', 'It should also be named "you"';
is_deeply [ map { $_->format_name } $orig->rework_tags ],
    [qw(@bar)], 'And it should have the one rework tag';
is $orig->deploy_file, $target->deploy_dir->file('you@bar.sql'),
    'The original file should now be named you@bar.sql';
is $rev_change->as_string,
    'you [you@bar] ' . $rev_change->timestamp->as_string . ' '
    . $rev_change->format_planner,
    'It should require the previous "you" change';
is [$plan->lines]->[-1], $rev_change,
    'The new "you" should have been appended to the lines, too';

# Make sure it was appended to the plan.
ok $plan->contains('you@HEAD'), 'Should find "you@HEAD" in plan';
is $plan->index_of('you@HEAD'), 8, 'It should be at position 8';
is $plan->count, 9, 'The plan count should be 9';

# Tag and add again, to be sure we can do it multiple times.
ok $plan->tag( name => '@beta1' ), 'Tag @beta1';
ok my $rev_change2 = $plan->rework( name => 'you' ),
    'Rework change "you" again';
isa_ok $rev_change2, 'App::Sqitch::Plan::Change';
is $rev_change2->name, 'you', 'New reworked change should be "you"';
ok $orig = $plan->change_at($plan->first_index_of('you')),
    'Get original "you" change again';
is $orig->name, 'you', 'It should still be named "you"';
is_deeply [ map { $_->format_name } $orig->rework_tags ],
    [qw(@bar)], 'And it should have the one rework tag';
ok $rev_change = $plan->get('you@beta1'), 'Get you@beta1';
is $rev_change->name, 'you', 'The second "you" should be named that';
is_deeply [ map { $_->format_name } $rev_change->rework_tags ],
    [qw(@beta1)], 'And the second change should have the rework_tag "@beta1"';
is_deeply [ $rev_change2->rework_tags ],
    [], 'But the new reworked change should have no rework tags';
is $rev_change2->as_string,
    'you [you@beta1] ' . $rev_change2->timestamp->as_string . ' '
    . $rev_change2->format_planner,
    'It should require the previous "you" change';
is [$plan->lines]->[-1], $rev_change2,
    'The new reworking should have been appended to the lines';

# Make sure it was appended to the plan.
ok $plan->contains('you@HEAD'), 'Should find "you@HEAD" in plan';
is $plan->index_of('you@HEAD'), 9, 'It should be at position 9';