commit - 3d657e5fb6ec4c05daf6972bc7d8693b5072a3d1
commit + ea5b31460b8101c592cf55d5c5dea682a225066b
blob - 88ad8b734d345544e842a52e086a9ab0e012b714
blob + b5eaf3c34dbc61afd17c7d084a13050b3166b515
--- commands.txt
+++ commands.txt
!axfr <domain> <nameserver>
!banner <host> <port>
!confession
+!fortune [subject or question]
!help
!ipinfo <IP|host>
!md5 <string>
blob - 0eb676381591f32b75aac415b1e2f7b4a8572427
blob + 444f5b0b54673d4e101634dee1fa2f46c6434e9a
--- crybot.pl
+++ crybot.pl
#!/usr/bin/env perl
+# Crybot - Developed by lex0de (lex0de@tuta.com)
+# cryobot/crybot.pl
use v5.24;
use strict;
use JSON::PP qw(decode_json encode_json);
use URI::Escape qw(uri_escape);
use MIME::Base64 qw(encode_base64);
-use Encode qw(decode);
+use Encode qw(decode encode);
use Time::HiRes qw(time);
use File::Spec;
use FindBin qw($Bin);
ud => \&cmd_ud,
sicksearch => \&cmd_sicksearch,
confession => \&cmd_confession,
+ fortune => \&cmd_fortune,
sickjoke => \&cmd_sickjoke,
ns => \&cmd_ns,
ipinfo => \&cmd_ipinfo,
say "[ $target ] <$nick> [checkip] $host | $cc:$org";
}
+sub cmd_fortune {
+ my ( $sock, $config, $nick, $target, $args, $is_private ) = @_;
+ my $reading = fortune_reading( cast_fortune() );
+ my $out = response_target( $nick, $target, $is_private );
+ send_fortune( $sock, $out, fortune_messages( $nick, $args, $reading ) );
+}
+
+# Return six totals, bottom first. An injected RNG accepts an exclusive limit.
+sub cast_fortune {
+ my ($rng) = @_;
+ $rng //= sub { rand $_[0] };
+ my @lines;
+ for ( 1 .. 6 ) {
+ my $total = 0;
+ $total += 2 + int $rng->(2) for 1 .. 3;
+ push @lines, $total;
+ }
+ return \@lines;
+}
+
+# Patterns run bottom to top, with 1 = yang. Advice is original, brief prose.
+# King Wen pattern cross-check: github.com/zzkt/i-ching, i-ching.el.
+# Traditional themes: sacred-texts.com/ich/ictoc.htm (Legge translation).
+sub fortune_hexagram {
+ my ($pattern) = @_;
+ state $hexagrams = do {
+ my %table;
+ my $number = 0;
+ my $data = <<'HEXAGRAMS';
+111111|The Creative|Take initiative, then sustain your effort.
+000000|The Receptive|Listen first; patient support opens the way.
+100010|Difficulty at the Beginning|Start small and gather help through confusion.
+010001|Youthful Folly|Admit what you do not know and seek guidance.
+111010|Waiting|Prepare carefully; let the right moment arrive.
+010111|Conflict|Seek common ground before pressing your case.
+010000|The Army|Bring discipline and a shared purpose to the task.
+000010|Holding Together|Choose reliable allies and commit sincerely.
+111011|Small Taming|Small improvements matter more than force today.
+110111|Treading|Advance with care and respect the risks.
+111000|Peace|Use this opening to build lasting cooperation.
+000111|Standstill|Protect your principles while progress is blocked.
+101111|Fellowship|Find a shared aim beyond personal differences.
+111101|Great Possession|Use your resources generously and responsibly.
+001000|Modesty|Let quiet competence carry more weight than pride.
+000100|Enthusiasm|Turn inspiration into a practical shared effort.
+100110|Following|Adapt willingly without abandoning your values.
+011001|Repair|Address the roots of what has gone wrong.
+110000|Approach|Meet new opportunities with care and foresight.
+000011|Contemplation|Step back and observe before choosing a direction.
+100101|Biting Through|Deal clearly and fairly with the real obstacle.
+101001|Grace|Choose a simple presentation with substance behind it.
+000001|Splitting Apart|Release what is failing and protect your foundations.
+100000|Return|Begin again gently; a small renewal can grow.
+100111|Innocence|Act honestly without forcing a clever outcome.
+111001|Great Taming|Build knowledge and restraint before using your power.
+100001|Nourishment|Notice what you feed your mind and offer others.
+011110|Great Preponderance|Ease the strain before taking on more weight.
+010010|The Abysmal Water|Keep your footing and take difficulties step by step.
+101101|The Clinging Fire|Seek clarity and attend to what sustains it.
+001110|Influence|Let openness and sincerity invite a response.
+011100|Duration|Steady habits can carry you through changing moods.
+001111|Retreat|A timely step back can preserve your strength.
+111100|Great Power|Use strength with restraint rather than pressure.
+000101|Progress|Make your work visible and advance with integrity.
+101000|Darkening of the Light|Guard your inner clarity in difficult surroundings.
+101011|The Family|Care for close relationships and shared responsibilities.
+110101|Opposition|Respect differences and cooperate on smaller aims.
+001010|Obstruction|Pause, seek support, and consider another route.
+010100|Deliverance|Resolve what remains, then let old tension go.
+110001|Decrease|Simplify willingly and spend your energy wisely.
+100011|Increase|Use growing resources to help something worthwhile.
+111110|Breakthrough|Speak plainly and act firmly without aggression.
+011111|Coming to Meet|Notice a powerful influence before inviting it closer.
+000110|Gathering Together|Bring people and resources around a clear purpose.
+011000|Pushing Upward|Patient, modest steps can lead to real growth.
+010110|Oppression|Conserve your strength and stay true under pressure.
+011010|The Well|Renew the shared sources of support you depend on.
+101110|Revolution|Change what is outdated when the time is right.
+011101|The Cauldron|Transform what you have into lasting nourishment.
+100100|The Arousing Thunder|Let surprise wake you without losing your balance.
+001001|Keeping Still|Quiet your reactions before deciding what comes next.
+001011|Development|Allow trust and progress to mature gradually.
+110100|The Marrying Maiden|Know your position and avoid forcing a commitment.
+101100|Abundance|Use a fruitful moment well; conditions will change.
+001101|The Wanderer|Travel lightly and respect unfamiliar surroundings.
+011011|The Gentle Wind|Patient, consistent influence can reach deep roots.
+110110|The Joyous Lake|Share honest encouragement without empty promises.
+010011|Dispersion|Loosen divisions and reconnect around shared values.
+110010|Limitation|Set workable boundaries that protect your energy.
+110011|Inner Truth|Let sincerity guide both your words and your listening.
+001100|Small Preponderance|Attend to small duties rather than grand gestures.
+101010|After Completion|Maintain what works; success still needs attention.
+010101|Before Completion|Proceed carefully; the final crossing is unfinished.
+HEXAGRAMS
+ for my $row ( split /\n/, $data ) {
+ my ( $bits, $name, $advice ) = split /\|/, $row;
+ $table{$bits} = {
+ number => ++$number,
+ name => $name,
+ advice => $advice,
+ };
+ }
+ \%table;
+ };
+ return unless defined $pattern && $pattern =~ /\A[01]{6}\z/;
+ return $hexagrams->{$pattern};
+}
+
+# Return the cast, changing positions (1 = bottom), and both hexagram records.
+sub fortune_reading {
+ my ($lines) = @_;
+ die "Invalid fortune cast\n" unless ref $lines eq 'ARRAY'
+ && @{$lines} == 6
+ && !grep { !defined $_ || !/\A[6-9]\z/ } @{$lines};
+ my @present = map { $_ % 2 } @{$lines};
+ my @future = map { $_ == 6 || $_ == 9 ? 1 - $_ % 2 : $_ % 2 }
+ @{$lines};
+ my @changing = grep { $lines->[$_ - 1] == 6 || $lines->[$_ - 1] == 9 }
+ 1 .. 6;
+ return {
+ lines => [ @{$lines} ],
+ present => fortune_hexagram( join '', @present ),
+ future => fortune_hexagram( join '', @future ),
+ changing => \@changing,
+ };
+}
+
+# Decode IRC bytes once and return a bounded, printable label.
+sub fortune_text {
+ my ( $text, $limit ) = @_;
+ $text //= '';
+ $text = decode( 'UTF-8', $text, Encode::FB_DEFAULT )
+ unless utf8::is_utf8($text);
+ $text =~ s/[\p{Cc}\p{Cf}]/ /g;
+ $text =~ s/\s+/ /g;
+ $text =~ s/^\s+|\s+$//g;
+ return substr $text, 0, $limit;
+}
+
+# Return ten decoded messages; cast arrays are bottom first, drawings top first.
+sub fortune_messages {
+ my ( $nick, $subject, $reading ) = @_;
+ $nick = fortune_text( $nick, 80 );
+ $subject = fortune_text( $subject, 80 );
+ $subject = 'your current situation' unless length $subject;
+ my ( $present, $future ) = @{$reading}{qw(present future)};
+ my $totals = join ',', @{ $reading->{lines} };
+ my $changes = join( ',', @{ $reading->{changing} } ) || 'none';
+ my @messages = (
+ "$nick: Three coins for $subject. "
+ . "Lines 1-6: $totals; changing: $changes.",
+ "Present #$present->{number} $present->{name} | "
+ . "Future #$future->{number} $future->{name} (* = changing)",
+ );
+ for my $index ( reverse 0 .. 5 ) {
+ my $total = $reading->{lines}[$index];
+ my $is_changing = $total == 6 || $total == 9;
+ my $yang = $total % 2;
+ my $next_yang = $is_changing ? !$yang : $yang;
+ push @messages, sprintf '%d %s%s | %s', $index + 1,
+ $yang ? '━━━━━━━' : '━━━ ━━━', $is_changing ? '*' : ' ',
+ $next_yang ? '━━━━━━━' : '━━━ ━━━';
+ }
+ push @messages, "Present: $present->{advice}";
+ push @messages, @{ $reading->{changing} }
+ ? "Possible direction: $future->{advice}"
+ : "Future: The outlook remains steady. $future->{advice}";
+ return \@messages;
+}
+
+# Send UTF-8 bytes through the existing raw writer, within the IRC frame limit.
+sub send_fortune {
+ my ( $sock, $target, $messages ) = @_;
+ return unless defined $target && length $target;
+ return if $target =~ /[\x00-\x20\x7F,]/;
+ $target = encode( 'UTF-8', $target ) if utf8::is_utf8($target);
+ my $prefix = "PRIVMSG $target :";
+ my $budget = 512 - length($prefix) - 2;
+ return if $budget < 1;
+ for my $message ( @{$messages} ) {
+ my $text = $message;
+ $text =~ s/[\p{Cc}\p{Cf}]/ /g;
+ my $bytes = encode( 'UTF-8', $text );
+ if ( length($bytes) > $budget ) {
+ my $clipped = substr $bytes, 0, $budget;
+ $bytes = encode( 'UTF-8',
+ decode( 'UTF-8', $clipped, Encode::FB_QUIET ) );
+ }
+ irc_print( $sock, $prefix . $bytes );
+ }
+}
+
sub cmd_help {
my ( $sock, $config, $nick, $target, $args, $is_private ) = @_;
my @lines = (
'- !ud <word> - UrbanDictionary',
'- !sickjoke - Sickipedia Joke',
'- !confession - Confession',
+ '- !fortune [subject or question] - I Ching reading',
);
my $out = response_target( $nick, $target, $is_private );
sub parse_irc_line {
my ($line) = @_;
my $prefix = '';
- if ( $line =~ s/^:([^\s]+)\s+// ) {
+ # IRC separators are ASCII; UTF-8 continuation bytes are not whitespace.
+ if ( $line =~ s/^:([^\s]+)\s+//a ) {
$prefix = $1;
}
push @params, $1;
last;
}
- $line =~ s/^(\S+)\s*//;
+ $line =~ s/^(\S+)\s*//a;
push @params, $1;
}
blob - /dev/null
blob + b1c33e04d1626ee6db685d2221e5476141e0acb6 (mode 644)
--- /dev/null
+++ t/fortune.t
+# Crybot - Developed by lex0de (lex0de@tuta.com)
+# cryobot/t/fortune.t
+
+use v5.24;
+use strict;
+use warnings;
+use utf8;
+
+use Encode qw(decode encode);
+use File::Temp qw(tempdir);
+use FindBin qw($Bin);
+use Test::More;
+
+my $directory = tempdir( CLEANUP => 1 );
+{
+ local %ENV = %ENV;
+ delete @ENV{ grep { /^CRYBOT_/ } keys %ENV };
+ $ENV{CRYBOT_FEED_STATE} = "$directory/state.json";
+ local @ARGV = ();
+ my $script = "$Bin/../crybot.pl";
+ my $loaded = do $script;
+ die "Unable to load $script: $@ $!" unless defined $loaded;
+}
+
+# Exercise the IRC parser and dispatcher with a raw in-memory socket substitute.
+sub capture_command {
+ my ( $target, $message, $config, $nick ) = @_;
+ $nick //= 'reader';
+ my $wire = '';
+ open my $sock, '>:raw', \$wire or die "open capture: $!";
+ handle_line( $sock, $config,
+ ":$nick!user\@example.invalid PRIVMSG $target :$message" );
+ close $sock or die "close capture: $!";
+ return $wire;
+}
+
+sub decoded_frames {
+ my ($wire) = @_;
+ return [ split /\r\n/, decode( 'UTF-8', $wire, Encode::FB_CROAK ) ];
+}
+
+subtest 'all three-coin outcomes have the expected exact odds' => sub {
+ my %frequency;
+ for my $outcome ( 0 .. 7 ) {
+ my @coins = map { ( $outcome >> $_ ) & 1 } 0 .. 2;
+ my $expected = 6 + $coins[0] + $coins[1] + $coins[2];
+ my $calls = 0;
+ my @limits;
+ my $lines = cast_fortune( sub {
+ my ($limit) = @_;
+ push @limits, $limit;
+ return $coins[$calls++ % 3];
+ } );
+ is_deeply( \@limits, [ (2) x 18 ], 'each coin has two sides' );
+ is( $calls, 18, 'six independent triples are cast' );
+ is_deeply( $lines, [ ($expected) x 6 ], 'coin values sum correctly' );
+ $frequency{ $lines->[0] }++;
+ }
+ is_deeply( \%frequency, { 6 => 1, 7 => 3, 8 => 3, 9 => 1 },
+ 'coin odds are 1:3:3:1' );
+ my $lines = cast_fortune();
+ is( scalar @{$lines}, 6, 'default RNG produces six lines' );
+ ok( !grep( { $_ < 6 || $_ > 9 } @{$lines} ), 'default totals are valid' );
+};
+
+subtest 'casts are built bottom first and only old lines change' => sub {
+ my @coins = ( 0, 0, 0, 1, 0, 0, 1, 1, 0,
+ 1, 1, 1, 1, 0, 0, 1, 1, 0 );
+ my $lines = cast_fortune( sub { shift @coins } );
+ is_deeply( $lines, [ 6, 7, 8, 9, 7, 8 ], 'bottom-first cast retained' );
+ my $reading = fortune_reading($lines);
+ is_deeply( $reading->{changing}, [ 1, 4 ], 'changing positions start at bottom' );
+ is( $reading->{present}{number}, 47, 'present is lake over water' );
+ is( $reading->{future}{number}, 60, 'future is water over lake' );
+ is_deeply( $reading->{lines}, $lines, 'cast is retained for display' );
+ is_deeply( $lines, [ 6, 7, 8, 9, 7, 8 ], 'input was not changed' );
+ for my $total ( 7, 8 ) {
+ my $steady = fortune_reading( [ ($total) x 6 ] );
+ is_deeply( $steady->{changing}, [], 'young lines are stable' );
+ is_deeply( $steady->{present}, $steady->{future}, 'steady result matches' );
+ }
+ my $all_yin = fortune_reading( [ (6) x 6 ] );
+ is( $all_yin->{present}{number}, 2, 'old yin starts as Earth' );
+ is( $all_yin->{future}{number}, 1, 'all old yin changes to Heaven' );
+ is_deeply( $all_yin->{changing}, [ 1 .. 6 ], 'all six positions change' );
+ my $all_yang = fortune_reading( [ (9) x 6 ] );
+ is( $all_yang->{present}{number}, 1, 'old yang starts as Heaven' );
+ is( $all_yang->{future}{number}, 2, 'all old yang changes to Earth' );
+};
+
+subtest 'invalid internal casts are rejected' => sub {
+ for my $input ( undef, {}, [], [ 7, 7, 7, 7, 7 ],
+ [ 7, 7, 7, 7, 7, 10 ], [ 7, 7, 7, 7, 7, undef ] ) {
+ my $ok = eval { fortune_reading($input); 1 };
+ ok( !$ok, 'invalid cast rejected' );
+ like( $@, qr/Invalid fortune cast/, 'failure describes the cast' );
+ }
+};
+
+subtest 'all 64 patterns agree with the traditional trigram matrix' => sub {
+ # Rows are lower trigrams; columns upper: heaven, lake, fire, thunder,
+ # wind, water, mountain, earth. Independent matrix checks bit orientation.
+ my @trigrams = qw(111 110 101 100 011 010 001 000);
+ my @matrix = (
+ [ 1, 43, 14, 34, 9, 5, 26, 11 ],
+ [ 10, 58, 38, 54, 61, 60, 41, 19 ],
+ [ 13, 49, 30, 55, 37, 63, 22, 36 ],
+ [ 25, 17, 21, 51, 42, 3, 27, 24 ],
+ [ 44, 28, 50, 32, 57, 48, 18, 46 ],
+ [ 6, 47, 64, 40, 59, 29, 4, 7 ],
+ [ 33, 31, 56, 62, 53, 39, 52, 15 ],
+ [ 12, 45, 35, 16, 20, 8, 23, 2 ],
+ );
+ my %seen;
+ for my $lower ( 0 .. 7 ) {
+ for my $upper ( 0 .. 7 ) {
+ my $pattern = $trigrams[$lower] . $trigrams[$upper];
+ my $hexagram = fortune_hexagram($pattern);
+ is( $hexagram->{number}, $matrix[$lower][$upper],
+ "correct King Wen number for $pattern" );
+ ok( length $hexagram->{name}, 'name exists' );
+ ok( length $hexagram->{advice}, 'interpretation exists' );
+ $seen{ $hexagram->{number} }++;
+ }
+ }
+ is_deeply( [ sort { $a <=> $b } keys %seen ], [ 1 .. 64 ],
+ 'all 64 King Wen numbers occur once' );
+ for my $pattern ( undef, '', '01010', '0101010', '01010x', "010101\n" ) {
+ ok( !defined fortune_hexagram($pattern), 'invalid pattern rejected' );
+ }
+};
+
+subtest 'ten messages draw matching diagrams from top to bottom' => sub {
+ my $reading = fortune_reading( [ 6, 7, 8, 9, 7, 8 ] );
+ my $messages = fortune_messages( 'reader', 'a new job', $reading );
+ is( scalar @{$messages}, 10, 'reply has a fixed ten-message size' );
+ like( $messages->[0], qr/reader: Three coins for a new job\./,
+ 'reading includes nick and subject' );
+ like( $messages->[0], qr/Lines 1-6: 6,7,8,9,7,8; changing: 1,4\./,
+ 'cast and changing positions are visible' );
+ like( $messages->[1], qr/Present #47 Oppression \| Future #60 Limitation/,
+ 'columns identify both hexagrams' );
+ is_deeply( [ @{$messages}[ 2 .. 7 ] ], [
+ '6 ━━━ ━━━ | ━━━ ━━━',
+ '5 ━━━━━━━ | ━━━━━━━',
+ '4 ━━━━━━━* | ━━━ ━━━',
+ '3 ━━━ ━━━ | ━━━ ━━━',
+ '2 ━━━━━━━ | ━━━━━━━',
+ '1 ━━━ ━━━* | ━━━━━━━',
+ ], 'solid, broken and changing lines are correctly drawn' );
+ is( $messages->[8], 'Present: ' . $reading->{present}{advice},
+ 'present interpretation matches the result' );
+ is( $messages->[9], 'Possible direction: ' . $reading->{future}{advice},
+ 'future interpretation matches the result' );
+};
+
+subtest 'unchanging fortunes show identical diagrams and steady outlook' => sub {
+ my $messages = fortune_messages( 'reader', '',
+ fortune_reading( [ (7) x 6 ] ) );
+ like( $messages->[0], qr/your current situation.*changing: none/,
+ 'missing subject defaults to a general reading' );
+ for my $index ( 0 .. 5 ) {
+ is( $messages->[$index + 2],
+ (6 - $index) . ' ━━━━━━━ | ━━━━━━━', 'both drawings match' );
+ }
+ like( $messages->[9], qr/outlook remains steady/, 'no invented transformation' );
+};
+
+subtest 'dispatch replies only to the requesting channel and connection' => sub {
+ no warnings 'redefine';
+ local *main::cast_fortune = sub { [ 6, 7, 8, 9, 7, 8 ] };
+ my $primary = { nick => 'GCHQ', silence => 'YES', channels => ['#primary'] };
+ my $secondary = { nick => 'OtherBot', silence => 'NO', channels => ['#other'] };
+ my $first = decoded_frames( capture_command( '#invited', '!fortune', $primary ) );
+ my $second = decoded_frames( capture_command(
+ '#other', '!FORTUNE should I move?', $secondary ) );
+ is( scalar @{$first}, 10, 'explicit command works even when silenced' );
+ is( scalar @{$second}, 10, 'case-insensitive command works on second server' );
+ ok( !grep( { !/^PRIVMSG #invited :/ } @{$first} ),
+ 'all first-connection replies go to the originating channel' );
+ ok( !grep( { !/^PRIVMSG #other :/ } @{$second} ),
+ 'all second-connection replies stay on that channel' );
+ like( $second->[0], qr/should I move\?/, 'optional sentence is preserved' );
+ my $private = decoded_frames( capture_command( 'GCHQ', '!fortune work', $primary ) );
+ is( scalar @{$private}, 10, 'private command is supported' );
+ ok( !grep( { !/^PRIVMSG reader :/ } @{$private} ),
+ 'private replies go to the requesting nick' );
+ is( capture_command( '#invited', '!fortuneunknown', $primary ), '',
+ 'other command names are not accidentally matched' );
+};
+
+subtest 'subjects are bounded and controls and malformed UTF-8 are handled' => sub {
+ is( fortune_text( " \x01work\r\n\0\t plans\x7F ", 80 ),
+ 'work plans', 'controls and whitespace are normalized' );
+ is( fortune_text( encode( 'UTF-8', '你好 café' ), 80 ),
+ '你好 café', 'raw UTF-8 is decoded once' );
+ is( fortune_text( '你好 café', 80 ), '你好 café', 'decoded text stays intact' );
+ is( fortune_text( "bad\xFFtopic", 80 ), "bad\x{FFFD}topic",
+ 'invalid bytes become replacement characters' );
+ is( fortune_text( '界' x 200, 80 ), '界' x 80,
+ 'subject limit counts characters' );
+ my $messages = fortune_messages( "reader\0injected", "\x01\r\n",
+ fortune_reading( [ (7) x 6 ] ) );
+ like( $messages->[0], qr/reader injected:.*your current situation/,
+ 'empty sanitized subjects default and nick controls are removed' );
+ my $zero = fortune_messages( 'reader', '0',
+ fortune_reading( [ (7) x 6 ] ) );
+ like( $zero->[0], qr/Three coins for 0\./, 'zero is a valid subject' );
+};
+
+subtest 'Unicode output is valid UTF-8 bytes on the wire' => sub {
+ no warnings 'redefine';
+ local *main::cast_fortune = sub { [ (6) x 6 ] };
+ my $config = { nick => 'GCHQ', silence => 'NO' };
+ my $target = encode( 'UTF-8', '#café读者' );
+ my $nick = encode( 'UTF-8', '读者' );
+ my $question = encode( 'UTF-8', '!fortune 我的未来' );
+ my $wire = capture_command( $target, $question, $config, $nick );
+ ok( !utf8::is_utf8($wire), 'socket capture contains bytes' );
+ my $messages = decoded_frames($wire);
+ is( scalar @{$messages}, 10, 'all Unicode messages round-trip' );
+ like( $messages->[0], qr/^PRIVMSG #café读者 :读者:.*我的未来/,
+ 'target, nick and subject retain Unicode' );
+ like( $messages->[2], qr/━━━ ━━━\* \| ━━━━━━━/,
+ 'drawing is encoded explicitly' );
+};
+
+subtest 'frames stay bounded and cannot inject extra IRC lines' => sub {
+ my $wire = '';
+ open my $sock, '>:raw', \$wire or die "open capture: $!";
+ my $target = '#' . ('a' x 300);
+ send_fortune( $sock, $target,
+ [ ('界' x 1_000), "line\r\nPRIVMSG #other :bad\0\x01" ] );
+ my @frames = split /\r\n/, $wire;
+ is( scalar @frames, 2, 'controls cannot create extra frames' );
+ for my $frame (@frames) {
+ cmp_ok( length($frame) + 2, '<=', 512, 'frame including CRLF fits' );
+ my $copy = $frame;
+ my $text = eval { decode( 'UTF-8', $copy, Encode::FB_CROAK ) };
+ ok( defined $text && !$@, 'truncation retains complete UTF-8 characters' );
+ unlike( $frame, qr/[\x00-\x1F\x7F]/, 'frame contains no control bytes' );
+ }
+ like( $wire, qr/\r\n\z/, 'wire frames end in CRLF' );
+ my $before = $wire;
+ for my $bad ( undef, '', "#bad\r\nJOIN #other", "#bad\0", '#a,#b',
+ '#' . ('a' x 510) ) {
+ send_fortune( $sock, $bad, ['never sent'] );
+ }
+ is( $wire, $before, 'invalid or oversized targets produce no output' );
+ close $sock or die "close capture: $!";
+
+ no warnings 'redefine';
+ local *main::cast_fortune = sub { [ (7) x 6 ] };
+ my $config = { nick => 'GCHQ', silence => 'NO' };
+ my $long_wire = capture_command( '#normal',
+ encode( 'UTF-8', '!fortune ' . ('界' x 2_000) ), $config );
+ my $messages = decoded_frames($long_wire);
+ my $displayed_subject = '界' x 80;
+ like( $messages->[0], qr/for \Q$displayed_subject\E\. Lines/,
+ 'dispatched long subject is capped at 80 characters' );
+ for my $frame ( split /\r\n/, $long_wire ) {
+ cmp_ok( length($frame) + 2, '<=', 512, 'each reply fits the wire limit' );
+ }
+};
+
+subtest 'help advertises the optional subject' => sub {
+ my $messages = decoded_frames( capture_command( '#channel', '!help',
+ { nick => 'GCHQ', silence => 'NO' } ) );
+ ok( scalar grep( /!fortune \[subject or question\]/, @{$messages} ),
+ 'command appears in bot help' );
+};
+
+done_testing;
