275 / 285 lines covered (96.5%)
1unit module BDD::Behave::DSL;23use BDD::Behave::Expectation;4use BDD::Behave::Failure;5use BDD::Behave::Failures;67need BDD::Behave::SpecRegistry;8need BDD::Behave::LetRuntime;9need BDD::Behave::SharedContexts;10need BDD::Behave::SharedExamples;11need BDD::Behave::Mock::ArgMatcher;12need BDD::Behave::Mock::Double;13need BDD::Behave::Mock::Allow;14need BDD::Behave::Mock::Spy;15need BDD::Behave::Matcher::Custom;16need BDD::Behave::Benchmark;17need BDD::Behave::Time;1819sub registry() { BDD::Behave::SpecRegistry::registry() }20sub shared-context-registry() { BDD::Behave::SharedContexts::registry() }21sub shared-examples-registry() { BDD::Behave::SharedExamples::registry() }22constant LetDefinition = BDD::Behave::LetRuntime::LetDefinition;2324sub normalize-tags(%meta --> List) {25 my @tags;26 for <tag tags> -> $key {27 next unless %meta{$key}:exists;28 my $value = %meta{$key};29 next unless $value.defined;30 if $value ~~ Positional {31 @tags.append: $value.list.map(*.Str);32 } else {33 @tags.push: $value.Str;34 }35 }36 @tags.unique.List;37}3839constant RESERVED-META = set <tag tags skipped focused auto-description>;4041sub extract-extra-meta(%meta --> Hash) {42 my %extra;43 for %meta.kv -> $key, $value {44 next if $key (elem) RESERVED-META;45 %extra{$key} = $value;46 }47 %extra;48}4950sub parse-hook-filter(%filter --> Hash) {51 my @include-tags;52 my @exclude-tags;53 my %meta;54 for %filter.kv -> $key, $value {55 given $key {56 when 'tag'|'tags' {57 if $value ~~ Positional {58 @include-tags.append: $value.list.map(*.Str);59 } else {60 @include-tags.push: $value.Str;61 }62 }63 when 'exclude-tag'|'exclude-tags' {64 if $value ~~ Positional {65 @exclude-tags.append: $value.list.map(*.Str);66 } else {67 @exclude-tags.push: $value.Str;68 }69 }70 default {71 %meta{$key} = $value;72 }73 }74 }75 %(76 :include-tags(@include-tags.unique.list),77 :exclude-tags(@exclude-tags.unique.list),78 :%meta,79 );80}8182our proto sub describe(|) is export {*}8384our multi sub describe(Str $description, &block, *%meta) is export {85 my $file = &block.file.IO;86 my $line = &block.line;87 my @tags = normalize-tags(%meta);88 my %extra-meta = extract-extra-meta(%meta);89 registry().register-group(90 :$description,91 :&block,92 :$file,93 :$line,94 :@tags,95 :%extra-meta,96 :skipped(%meta<skipped> // False),97 :focused(%meta<focused> // False),98 );99 Nil;100}101102our multi sub describe(*@, *%) is export {103 die "describe expects a description string and a block";104}105106our sub context(|c) is export { describe(|c) }107108our sub fdescribe(Str $description, &block, *%meta) is export {109 describe($description, &block, |%meta, :focused);110}111112our sub xdescribe(Str $description, &block, *%meta) is export {113 describe($description, &block, |%meta, :skipped);114}115116our sub fcontext(|c) is export { fdescribe(|c) }117our sub xcontext(|c) is export { xdescribe(|c) }118119our sub let(|c) is export {120 my @pos = c.list;121 my %named = c.hash;122 my $name;123 my $block;124125 my $has-block = @pos.first(* ~~ Callable).defined;126127 unless $has-block {128 my $fetch-name;129130 if @pos.elems == 1 && @pos[0] ~~ Str && !%named {131 $fetch-name = @pos[0];132 } elsif @pos.elems == 0 && %named.elems == 1 {133 $fetch-name = %named.keys[0].Str;134 } else {135 die "let expects either let('name', \{ block \}) or let(:name, \{ block \}), or a fetch form let('name') / let(:name)";136 }137138 return let-value($fetch-name);139 }140141 if @pos.elems == 2 && @pos[0] ~~ Str && @pos[1] ~~ Callable {142 $name = @pos[0];143 $block = @pos[1];144 } elsif @pos.elems == 1 && @pos[0] ~~ Callable && %named.elems == 1 {145 $block = @pos[0];146 $name = %named.keys[0].Str;147 } else {148 die "let expects either let('name', \{ block \}) or let(:name, \{ block \})";149 }150151 my $file = $block.file.IO;152 my $line = $block.line;153 my $definition = LetDefinition.new(:name($name), :block($block), :$file, :$line);154155 my $in-runtime = False;156 try {157 $in-runtime = $*LET-RUNTIME.defined;158 }159160 if $in-runtime {161 $*LET-RUNTIME.add-definition($definition);162163 return $*LET-RUNTIME.value($name);164 }165166 my $registry = registry();167 my $entry = $registry.current-entry;168169 if $entry && $entry.stack.elems {170 my $current = $entry.stack[*-1];171 $current.add-let($definition);172 } else {173 my $suite = $registry.suite-for($file);174 $suite.add-let($definition);175 }176177 $definition;178}179180our sub let-value(Str:D $name) is export {181 my $runtime;182 try {183 $runtime = $*LET-RUNTIME if $*LET-RUNTIME.defined;184 }185186 unless $runtime.defined {187 die "let(:$name) fetch form must be called while an example is running";188 }189190 $runtime.value($name);191}192193our sub let-bang(|c) is export {194 my $entry = registry().current-entry;195196 unless $entry && $entry.stack.elems {197 die "let-bang must be called inside a describe/context block";198 }199200 my $definition = let(|c);201 unless $definition ~~ LetDefinition {202 die "let-bang must be called inside a describe/context block";203 }204205 my $name = $definition.name.subst(/^':'/, '');206 my $current = $entry.stack[*-1];207 my &force-block = sub { $*LET-RUNTIME.value($name) if $*LET-RUNTIME.defined };208 $current.add-hook('before-each', &force-block);209210 $definition;211}212213sub register-subject(Str:D $name, &block, Bool :$is-named) {214 my $primary = let($name, &block);215 if $is-named {216 let('subject', sub { $*LET-RUNTIME.value($name) });217 }218 $primary;219}220221sub install-subject-eager-hook(Str $caller-name) {222 my $entry = registry().current-entry;223 unless $entry && $entry.stack.elems {224 die "$caller-name must be called inside a describe/context block";225 }226 my $current = $entry.stack[*-1];227 my &force-block = sub { $*LET-RUNTIME.value('subject') if $*LET-RUNTIME.defined };228 $current.add-hook('before-each', &force-block);229}230231our proto sub subject(|) is export {*}232233our multi sub subject(--> Mu) {234 my $rt;235 try { $rt = $*LET-RUNTIME if $*LET-RUNTIME.defined }236 unless $rt.defined {237 die "subject() with no arguments must be called inside an example";238 }239 $rt.value('subject');240}241242our multi sub subject(Str:D $name, &block) {243 register-subject($name, &block, :is-named);244}245246our multi sub subject(&block, *%named) {247 if %named.elems == 0 {248 register-subject('subject', &block);249 } elsif %named.elems == 1 {250 register-subject(%named.keys[0].Str, &block, :is-named);251 } else {252 die "subject expects at most one named argument";253 }254}255256our proto sub subject-bang(|) is export {*}257258our multi sub subject-bang(Str:D $name, &block) {259 install-subject-eager-hook('subject-bang');260 register-subject($name, &block, :is-named);261}262263our multi sub subject-bang(&block, *%named) {264 install-subject-eager-hook('subject-bang');265 if %named.elems == 0 {266 register-subject('subject', &block);267 } elsif %named.elems == 1 {268 register-subject(%named.keys[0].Str, &block, :is-named);269 } else {270 die "subject-bang expects at most one named argument";271 }272}273274sub register-hook(Str $phase, &block, *%filter) {275 my $entry = registry().current-entry;276277 unless $entry && $entry.stack.elems {278 die "$phase must be called inside a describe/context block";279 }280281 my $current = $entry.stack[*-1];282 my %parsed = parse-hook-filter(%filter);283 $current.add-hook($phase, &block, |%parsed);284}285286our sub before-all(&block, *%filter) is export {287 register-hook('before-all', &block, |%filter);288}289our sub after-all(&block, *%filter) is export {290 register-hook('after-all', &block, |%filter);291}292our sub before-each(&block, *%filter) is export {293 register-hook('before-each', &block, |%filter);294}295our sub after-each(&block, *%filter) is export {296 register-hook('after-each', &block, |%filter);297}298our sub around-each(&block, *%filter) is export {299 register-hook('around-each', &block, |%filter);300}301our sub around-all(&block, *%filter) is export {302 register-hook('around-all', &block, |%filter);303}304305our sub shared-context(Str:D $name, &block) is export {306 shared-context-registry().register($name, &block);307}308309our sub include-context(Str:D $name, |args) is export {310 my $entry = registry().current-entry;311312 unless $entry && $entry.stack.elems {313 die "include-context must be called inside a describe/context block";314 }315316 my &block = shared-context-registry().lookup($name);317 block(|args);318}319320our sub shared-examples(Str:D $name, &block) is export {321 shared-examples-registry().register($name, &block);322}323324our sub include-examples(Str:D $name, |args) is export {325 my $entry = registry().current-entry;326327 unless $entry && $entry.stack.elems {328 die "include-examples must be called inside a describe/context block";329 }330331 my &block = shared-examples-registry().lookup($name);332 block(|args);333}334335our sub it-behaves-like(Str:D $name, |args) is export {336 my $entry = registry().current-entry;337338 unless $entry && $entry.stack.elems {339 die "it-behaves-like must be called inside a describe/context block";340 }341342 my $parent-group = $entry.stack[*-1];343 my &shared-block = shared-examples-registry().lookup($name);344 my &wrapper = sub { shared-block(|args) };345346 registry().register-group(347 description => "behaves like '$name'",348 block => &wrapper,349 file => $parent-group.file,350 line => &shared-block.line,351 );352}353354our proto sub it(|) is export {*}355356our multi sub it(Str $description, &block, *%meta) is export {357 my $file = &block.file.IO;358 my $line = &block.line;359 my @tags = normalize-tags(%meta);360 my %extra-meta = extract-extra-meta(%meta);361 registry().register-example(362 :$description,363 :&block,364 :$file,365 :$line,366 :@tags,367 :%extra-meta,368 :skipped(%meta<skipped> // False),369 :focused(%meta<focused> // False),370 );371 Nil;372}373374our multi sub it(&block, *%meta) is export {375 my $file = &block.file.IO;376 my $line = &block.line;377 my $description = "example at {$file.basename}:$line";378 my @tags = normalize-tags(%meta);379 my %extra-meta = extract-extra-meta(%meta);380 my $example = registry().register-example(381 :$description,382 :&block,383 :$file,384 :$line,385 :@tags,386 :%extra-meta,387 :skipped(%meta<skipped> // False),388 :focused(%meta<focused> // False),389 );390 $example.set-metadata(:auto-description(True));391 Nil;392}393394our sub double(|args) is export {395 BDD::Behave::Mock::Double::double(|args);396}397398our sub spy(|args) is export {399 BDD::Behave::Mock::Spy::spy(|args);400}401402our sub allow(Mu \target) is export {403 BDD::Behave::Mock::Allow::allow(target);404}405406our sub allow-any-instance-of(Mu \cls) is export {407 BDD::Behave::Mock::Allow::allow-any-instance-of(cls);408}409410our sub anything() is export { BDD::Behave::Mock::ArgMatcher::anything() }411our sub instance-of(Mu \type) is export { BDD::Behave::Mock::ArgMatcher::instance-of(type) }412our sub hash-including(*%pairs) is export { BDD::Behave::Mock::ArgMatcher::hash-including(|%pairs) }413our sub array-including(*@items) is export { BDD::Behave::Mock::ArgMatcher::array-including(|@items) }414415our sub define-matcher(Str:D $name, *%blocks) is export {416 BDD::Behave::Matcher::Custom::define-matcher($name, |%blocks);417}418419our sub matcher(Str:D $name, |c) is export {420 BDD::Behave::Matcher::Custom::matcher($name, |c);421}422423our sub benchmark(|c) is export {424 BDD::Behave::Benchmark::benchmark(|c);425}426427our sub freeze-time(|c) is export {428 BDD::Behave::Time::freeze-time(|c);429}430431our sub travel-to($when, &block) is export {432 BDD::Behave::Time::travel-to($when, &block);433}434435our sub travel-by(Real() $delta) is export {436 BDD::Behave::Time::travel-by($delta);437}438439our sub current-time() is export {440 BDD::Behave::Time::current-time();441}442443our proto sub fit(|) is export {*}444445our multi sub fit(Str $description, &block, *%meta) is export {446 it($description, &block, |%meta, :focused);447}448449our multi sub fit(&block, *%meta) is export {450 it(&block, |%meta, :focused);451}452453our proto sub xit(|) is export {*}454455our multi sub xit(Str $description, &block, *%meta) is export {456 it($description, &block, |%meta, :skipped);457}458459our multi sub xit(&block, *%meta) is export {460 it(&block, |%meta, :skipped);461}462463our proto sub specify(|) is export {*}464465our multi sub specify(Str $description, &block, *%meta) is export {466 it($description, &block, |%meta);467}468469our multi sub specify(&block, *%meta) is export {470 it(&block, |%meta);471}472473our proto sub example(|) is export {*}474475our multi sub example(Str $description, &block, *%meta) is export {476 it($description, &block, |%meta);477}478479our multi sub example(&block, *%meta) is export {480 it(&block, |%meta);481}482483our proto sub pending(|) is export {*}484485our multi sub pending(Str $reason, &block, *%meta) is export {486 my $file = &block.file.IO;487 my $line = &block.line;488 my @tags = normalize-tags(%meta);489 my %extra-meta = extract-extra-meta(%meta);490 my $example = registry().register-example(491 :description($reason),492 :&block,493 :$file,494 :$line,495 :@tags,496 :%extra-meta,497 );498 $example.mark-pending(:reason($reason));499 Nil;500}501502# Every `expect` lands here, and each `callframe` call re-walks the chain from503# the top, so the frame the loop stops on is the one returned.504sub caller-outside-behave() {505 my $depth = 1;506 my $frame = callframe($depth);507508 while $frame.defined && ($frame.file // '').contains('BDD/Behave') {509 $frame = callframe(++$depth);510 }511512 $frame;513}514515our multi sub pending(Str $reason, *%meta) is export {516 my $frame = caller-outside-behave();517 my $file = ($frame.defined ?? $frame.file !! 'unknown').IO;518 my $line = ($frame.defined ?? $frame.line.Int !! 0);519 my &block = sub { Nil };520 my @tags = normalize-tags(%meta);521 my %extra-meta = extract-extra-meta(%meta);522 my $example = registry().register-example(523 :description($reason),524 :&block,525 :$file,526 :$line,527 :@tags,528 :%extra-meta,529 );530 $example.mark-pending(:reason($reason));531 Nil;532}533534535sub format-inner-failure($f --> Str) {536 my $location = "{$f.file // ''}:{$f.line // 0}";537 if $f.message.defined {538 my @lines = $f.message.lines;539 my $head = " - $location: " ~ (@lines.head // '');540 my @tail = @lines.skip(1).map({ " $_" });541 ($head, |@tail).join("\n");542 } elsif $f.given.defined || $f.expected.defined {543 my $op = $f.negated ?? 'not to be' !! 'to be';544 " - $location:\n Expected: {$f.given.raku}\n $op: {$f.expected.raku}";545 } else {546 " - $location";547 }548}549550sub run-aggregate-failures(Str $label, &block, Str $file, Int $line --> Nil) {551 my $watermark = Failures.list.elems;552 my $exception;553 {554 my $*BEHAVE-AGGREGATION-LABEL = $label;555 my $*BEHAVE-AGGREGATING = True;556 try {557 block();558 CATCH {559 when X::BDD::Behave::ExpectationFailed { }560 default { $exception = $_; }561 }562 }563 }564565 my @inner = Failures.list[$watermark .. *].list;566567 if $exception.defined {568 @inner.push: Failure.new(569 :$file, :$line,570 :message('exception in aggregate-failures: ' ~ $exception.message),571 :aggregation-label($label),572 );573 }574575 return unless @inner.elems;576577 Failures.list.splice($watermark, *);578579 my $n = @inner.elems;580 my $header = "$n expectation" ~ ($n == 1 ?? '' !! 's')581 ~ ' failed inside aggregate-failures';582 my @body = @inner.map(&format-inner-failure);583 my $message = ($header, |@body).join("\n");584585 Failures.list.push(Failure.new(586 :$file, :$line, :$message,587 :aggregation-label($label),588 ));589}590591our sub capture-failures(&block --> List) is export {592 my $watermark = Failures.list.elems;593 {594 my $*BEHAVE-AGGREGATING = True;595 try {596 block();597 CATCH {598 when X::BDD::Behave::ExpectationFailed { }599 }600 }601 }602 my @captured = Failures.list[$watermark .. *].list;603 Failures.list.splice($watermark, *);604 @captured.List;605}606607sub user-callsite(--> List) {608 my $depth = 1;609 loop {610 my $frame = callframe($depth);611 last unless $frame.defined;612 my $file = ($frame.file // '').Str;613 if !$file.contains('lib/BDD/Behave') {614 return ($file, $frame.line.Int).List;615 }616 $depth++;617 last if $depth > 30;618 }619 ('', 0).List;620}621622our proto sub aggregate-failures(|) is export {*}623624our multi sub aggregate-failures(&block) is export {625 my ($caller-file, $caller-line) := user-callsite();626 my $inherited;627 try { $inherited = $*BEHAVE-AGGREGATION-LABEL if $*BEHAVE-AGGREGATION-LABEL.defined; }628 run-aggregate-failures($inherited // Str, &block, $caller-file, $caller-line);629}630631our multi sub aggregate-failures(Str:D $label, &block) is export {632 my ($caller-file, $caller-line) := user-callsite();633 run-aggregate-failures($label, &block, $caller-file, $caller-line);634}635636our sub is-expected() is export {637 my $caller-file = callframe(1).file.Str;638 my $caller-line = callframe(1).line.Int;639640 my $rt;641 try { $rt = $*LET-RUNTIME if $*LET-RUNTIME.defined }642 unless $rt.defined {643 die "is-expected must be called inside an example";644 }645646 my $resolved-given;647 try {648 $resolved-given = $rt.value('subject');649 CATCH {650 default {651 die "is-expected requires a subject (define one with `subject`)";652 }653 }654 }655656 ExpectationBuilder.new(657 :given($resolved-given),658 :file($caller-file),659 :line($caller-line)660 );661}662663our sub expect(|c) is export {664 # Walk up callframes to the first one outside the BDD::Behave codebase so665 # the failure location points at the user's expect(...) call site, not at666 # the internal proxy in lib/BDD/Behave.rakumod that re-dispatches to here.667 my $frame = caller-outside-behave();668 my $caller-file = ($frame.defined ?? $frame.file.Str !! 'unknown');669 my $caller-line = ($frame.defined ?? $frame.line.Int !! 0);670671 my @pos = c.list;672 my %named = c.hash;673674 my $resolved-given;675 if %named.elems == 1 && @pos.elems == 0 {676 my $key = %named.keys[0];677 678 try {679 680 $resolved-given = $*LET-RUNTIME.value($key) if $*LET-RUNTIME.defined;681 682 CATCH {683 default {684 685 die "Unknown let(:$key): " ~ .message;686 }687 }688 }689 } elsif @pos.elems == 1 {690 my $given = @pos[0];691 692 $resolved-given = $given;693 if $given ~~ Pair {694 try {695 $resolved-given = $*LET-RUNTIME.value($given.key) if $*LET-RUNTIME.defined;696 }697 }698 } else {699 die "expect requires either a positional argument or a single named argument";700 }701702 ExpectationBuilder.new(703 :given($resolved-given),704 :file($caller-file),705 :line($caller-line)706 );707}