Sponsoring The Perl Toolchain Summit 2025: Help make this important event another success Learn more

#!perl
#
# This script tests whether submited data looks good
use strict;
use Encode;
my $testfile = 'test.png';
my $testfile_path = catfile( 't' => 'data' => $testfile );
my $testfile_content = do {
my $fh = IO::File->new($testfile_path)
or die "Couldn't open $testfile_path $!";
local $/;
<$fh>;
};
my ( $reply_header, $reply_body ) = do {
my $binary_string = $testfile_content;
my $length = length($binary_string);
$binary_string =~ s/\n/\n /sg;
my $body = <<"EOF";
id: 873
Subject: \nCreator: 12
Created: 2013-11-06 07:15:36
Transaction: 1457
Parent: 871
MessageId: \nFilename: prova2.png
ContentType: image/png
ContentEncoding: base64
Headers: Content-Type: image/png; name="prova2.png"
Content-Disposition: attachment; filename="prova2.png"
Content-Transfer-Encoding: base64
Content-Length: $length
Content: $binary_string
EOF
( 'RT/4.0.7 200 Ok', $body );
};
my $http_payload = $reply_header . "\n\n" . $reply_body . "\n\n";
my $http_reply =
"HTTP/1.1 200 OK\r\n"
. "Content-Type: text/plain; charset=utf-8\r\n\r\n"
. $http_payload;
my $pipe = IO::Pipe->new; # Used to get port number
my $pid = fork;
die "cannot fork: $!" if not defined $pid;
if ( 0 == $pid ) { # Child
$pipe->writer;
{
package My::Web::Server;
sub handle_request {
print $http_reply;
}
# A hack to get HTTP::Server::Simple listen on ephemeral port.
# See RT#72987
sub after_setup_listener {
use Socket;
my $sock = getsockname HTTP::Server::Simple::HTTPDaemon;
my ($port) = ( sockaddr_in($sock) )[0];
$pipe->print("$port\n");
$pipe->close;
}
}
my $server = My::Web::Server->new('00');
alarm 120; # Just in case, don't hang people
$server->run; # Run until killed
die 'unreachable code';
}
$pipe->reader;
chomp( my $port = <$pipe> );
#diag("set up web server on port $port");
$pipe->close;
unless ( $port && $port =~ /^\d+$/ ) {
kill 9, $pid;
waitpid $pid, 0;
plan skip_all => 'could not get port number from child, skipping all tests';
}
plan tests => 4;
{
my $res = HTTP::Response->parse($http_reply);
ok( $res->content eq $http_payload,
'self-test: HTTP::Response gives back correct payload' );
}
my $rt = RT::Client::REST->new(
server => "http://127.0.0.1:$port",
timeout => 2,
);
# avoid need to login
$rt->basic_auth_cb( sub { return } );
{
my $res =
$rt->get_attachment( parent_id => 130, id => 873, undecoded => 1 );
ok(
$res->{Content} eq $testfile_content,
'binary files match with undecoded option'
);
}
{
my $res =
$rt->get_attachment( parent_id => 130, id => 873, undecoded => 0 );
ok(
$res->{Content} ne encode( 'latin1', $testfile_content ),
q|binary files don't match when decoded to latin1|
);
ok(
$res->{Content} ne encode( 'utf-8', $testfile_content ),
q|binary files don't match when decoded to utf8|
);
}
kill 9, $pid;
waitpid $pid, 0;
exit;