The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

CONTRA / Test-Smoke-1.84 / lib / Test / Smoke / Poster.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
—
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
—
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
—
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

              
package Test::Smoke::Poster;
use warnings;
use strict;
use Carp;
our $VERSION = '0.001';
use Cwd qw/:DEFAULT abs_path/;
use File::Spec::Functions qw/:DEFAULT rel2abs/;
use Test::Smoke::Poster::Curl;
use Test::Smoke::Poster::HTTP_Tiny;
use Test::Smoke::Poster::LWP_UserAgent;
=head1 NAME
Test::Smoke::Poster - Factory for poster objects.
=head1 SYNOPSIS
    use Test::Smoke::Poster;
    my $poster = Test::Smoke::Poster->new(
        'LWP::UserAgent',
        ddir => '.',
        smokedb_url => 'http://perl5.test-smoke.org/report',
    );
    $poster->post();
=head1 DESCRIPTION
Returns a instance of the object-class requested.
=cut
my %CONFIG = (
    df_poster  => 'HTTP::Tiny',
    df_ddir    => undef,
    df_jsnfile => 'mktest.jsn',
    df_qfile   => undef,
    df_v       => 0,
    df_smokedb_url => 'https://perl5.test-smoke.org/api/report',
    df_ua_timeout => undef,
    df_curlargs => [ ],
    'LWP::UserAgent' => {
        allowed  => [qw/ua_timeout/],
        required => [],
        class    => 'Test::Smoke::Poster::LWP_UserAgent',
    },
    'HTTP::Tiny' => {
        allowed => [qw/ua_timeout/],
        required => [],
        class => 'Test::Smoke::Poster::HTTP_Tiny',
    },
    'curl' => {
        allowed => [qw/curlbin curlargs ua_timeout/],
        required => [qw/curlbin/],
        class => 'Test::Smoke::Poster::Curl',
    },
    valid_type => {
        'LWP::UserAgent' => 1,
        'HTTP::Tiny'     => 1,
    },
    general_options => [qw/ddir jsnfile qfile v smokedb_url poster/],
);
=head2 Test::Smoke::Poster->new($poster_type, %arguments)
Check arguments and return an instance of $poster_type.
=cut
sub new {
    my $factory = shift;
    my $poster = shift || $CONFIG{df_poster};
    my %args = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
    my %fields = map {
        my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
        ( $_ => $value )
    } ( @{ $CONFIG{general_options} }, @{ $CONFIG{$poster}{allowed} } );
    if ( ! file_name_is_absolute( $fields{ddir} ) ) {
        $fields{ddir} = catdir( abs_path(), $fields{ddir} );
    }
    $fields{ddir} = rel2abs( $fields{ddir}, abs_path() );
    $fields{poster} = $poster;
    my @missing;
    for my $required (@{ $CONFIG{$poster}{required} }) {
        push(
            @missing,
            "option '$required' missing for '$CONFIG{$poster}{class}'"
        ) if !defined $fields{$required};
    }
    if (@missing) {
        croak("Missing option:\n\t", join("\n\t", @missing));
    }
    my $class = $CONFIG{$poster}{class};
    return $class->new(%fields);
}
1;
=head1 COPYRIGHT
(c) 2002-2013, Abe Timmerman <abeltje@cpan.org> All rights reserved.
With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
Rich Rauenzahn, David Cantrell.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
See:
=over 4
=item * L<http://www.perl.com/perl/misc/Artistic.html>
=item * L<http://www.gnu.org/copyleft/gpl.html>
=back
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut