File Coverage

File:blib/lib/App/FileSync/Transport/Local.pm
Coverage:89.8%

linestmtbrancondsubtimecode
1package App::FileSync::Transport::Local;
2
3# Runs filesync-server as a child process and speaks the wire protocol over
4# its pipes.  Used by the test suite, and for a server directory that is
5# local to the client (a NAS mount, say).
6
7
313
313
313
313
841
342
4525
use App::FileSync::Platform;
8
9
313
313
313
313
591
316
2649
use strict;
10
313
313
313
313
481
238
6443
use warnings;
11
12# Not :all - this class has a close method, and autodie replaces a package's
13# subs named after the builtins it wraps.
14
313
313
313
313
514
253
700
use autodie qw(open);
15
16
313
313
313
313
38219
348
7397
use File::Basename qw(dirname);
17
313
313
313
313
703
321
3243
use File::Spec;
18
313
313
313
313
62340
386997
3538
use IPC::Open3 ();
19
313
313
313
313
858
288
7528
use Readonly;
20
313
313
313
313
596
268
1019
use Sub::Private { mode => 'enforce' };
21
22
313
313
313
313
31490
275
5793
use App::FileSync::Args qw(named);
23
313
313
313
313
555
258
13819
use App::FileSync::Constants qw($ROLE_CLIENT $SERVER_PROGRAM);
24
313
313
313
313
645
267
4533
use App::FileSync::I18N qw(throw);
25
26
313
313
313
313
529
305
782
use version; our $VERSION = version->declare('0.001.1');
27
28# How far up from this file to look for a checkout's bin/filesync-server:
29# lib/App/FileSync/Transport is four levels, blib/lib/... five.
30Readonly my $SEARCH_DEPTH => 6;
31
32=encoding utf8
33
34 - 98
=head1 NAME

App::FileSync::Transport::Local - run the server as a local child process

=head1 SYNOPSIS

        my $transport = App::FileSync::Transport::Local->new(
                root => '/srv/filesync', repo => 'docs', client => 'laptop',
        );
        my $connection = App::FileSync::Protocol->new(in => $transport->reader, out => $transport->writer);
        ...
        $transport->close;

=head1 METHODS

=head2 new

Purpose: start a server for one session.

Args: C<root> (the server root), C<repo>, C<client>, optional C<role>
(default C<client>) and C<server_bin> (default C<FILESYNC_SERVER_BIN>, then a
F<bin/filesync-server> found above this module, then C<filesync-server> on
the PATH).

Returns: the transport.

Side Effects: starts C<$^X server_bin --root ... --repo ... --client ...
--role ...>.  The child's standard error is the parent's, never the protocol
pipe: sharing it would put diagnostics into the protocol stream.

Usage:

        my $transport = App::FileSync::Transport::Local->new(%args);

=head3 EXAMPLE

        my $t = App::FileSync::Transport::Local->new(root => $root, repo => 'docs', client => 'test-1');
        print {$t->writer} ...;

=head3 API SPECIFICATION

=head4 INPUT

        {
                root       => { type => 'string', min => 1 },
                repo       => { type => 'string', min => 1 },
                client     => { type => 'string', min => 1 },
                role       => { type => 'string', optional => 1 },
                server_bin => { type => 'string', optional => 1 },
        }

=head4 OUTPUT

        { type => 'object', isa => 'App::FileSync::Transport::Local' }

=head3 MESSAGES

        Key                 Meaning                     Resolution
        transport.missing   root, repo or client absent  pass it

=head3 FORMAL SPECIFICATION

        new(a) ⇒ ∃ child • argv(child) = ⟨perl, bin, --root, a.root, --repo, a.repo, --client, a.client, --role, role⟩

=cut
99
100sub new {
101
164
164
2596
        my $class = shift;
102        my $args = named(\@_, {
103
164
820
363
1483
                map({ $_ => { type => 'string', optional => 1 } } qw(root repo client role server_bin)),
104        }, 'Transport::Local->new');
105
106
164
482
        for my $required (qw(root repo client)) {
107                throw('transport.missing', { transport => 'Local', what => $required })
108
492
50
33
918
                        unless defined $args->{$required} && length $args->{$required};
109        }
110
111        my @command = (
112                $^X, $args->{server_bin} || _default_server_bin(),
113                '--root',   $args->{root},
114                '--repo',   $args->{repo},
115                '--client', $args->{client},
116
164
67
33
552
                '--role',   $args->{role} || $ROLE_CLIENT,
117        );
118
119        # '>&STDERR' dups the parent's stderr.  Passing a filehandle here would not
120        # redirect the child at all: it would write into an unread pipe, and the
121        # first log line would kill it with SIGPIPE.
122
164
245
        my ($writer, $reader);
123
164
583
        my $pid = IPC::Open3::open3($writer, $reader, '>&STDERR', @command);
124
125
164
474935
        return bless { pid => $pid, writer => $writer, reader => $reader }, $class;
126}
127
128 - 168
=head2 reader

Documented with L</writer> below.

=head2 writer

Purpose: the pipes to and from the server.

Args: none.

Returns: the read handle (server's stdout) or write handle (its stdin).

Side Effects: none.

Usage:

        my $in = $transport->reader;

=head3 EXAMPLE

        App::FileSync::Protocol->new(in => $t->reader, out => $t->writer);

=head3 API SPECIFICATION

=head4 INPUT

        [ { name => 'self', type => 'object' } ]

=head4 OUTPUT

        { type => 'object' }

=head3 MESSAGES

None.

=head3 FORMAL SPECIFICATION

        reader = self.reader ; writer = self.writer

=cut
169
170sub reader {
171
164
164
490
        my ($self) = @_;
172
173
164
760
        return $self->{reader};
174}
175
176sub writer {
177
164
164
294
        my ($self) = @_;
178
179
164
1626
        return $self->{writer};
180}
181
182 - 219
=head2 close

Purpose: end the session's process.

Args: none.

Returns: 1.  Repeated calls do nothing.

Side Effects: closes both pipes (the server sees end of file) and reaps the
child.

Usage:

        $transport->close;

=head3 EXAMPLE

        $transport->close;   # safe to call twice

=head3 API SPECIFICATION

=head4 INPUT

        [ { name => 'self', type => 'object' } ]

=head4 OUTPUT

        { type => 'integer', memberof => [ 1 ] }

=head3 MESSAGES

None.

=head3 FORMAL SPECIFICATION

        closed' = 1 ∧ child ∉ processes'

=cut
220
221sub close {     ## no critic (Subroutines::ProhibitBuiltinHomonyms, Subroutines::ProhibitAmbiguousNames) -- transport interface
222
164
164
9770
        my ($self) = @_;
223
224
164
50
428
        return 1 if $self->{closed}++;
225
226        # Pipe close failures mean the child already went; reaping still matters.
227
164
328
164
256
645
300
        for my $handle (grep { defined } @{$self}{qw(writer reader)}) {
228
328
1460
                CORE::close($handle);
229        }
230
164
50
219827065
        waitpid($self->{pid}, 0) if $self->{pid};
231
232
164
2174
        return 1;
233}
234
235 - 272
=head2 error_text

Purpose: what the transport itself said, for when the protocol failed.

Args: none.

Returns: an empty string: the local server writes its diagnostics to this
process's own standard error, which the user already sees.

Side Effects: none.

Usage:

        my $text = $transport->error_text;

=head3 EXAMPLE

        print $transport->error_text, "\n";

=head3 API SPECIFICATION

=head4 INPUT

        [ { name => 'self', type => 'object' } ]

=head4 OUTPUT

        { type => 'string' }

=head3 MESSAGES

None.

=head3 FORMAL SPECIFICATION

        error_text = ""

=cut
273
274sub error_text {
275
0
0
        return '';
276}
277
278# _default_server_bin
279# Purpose:     find the server program when none is configured.
280# Entry:       none.
281# Exit:        returns FILESYNC_SERVER_BIN, a bin/filesync-server found by
282#              walking up from this file (a checkout, or blib under
283#              "make test"), or the bare name (installed, on the PATH).
284# Side effects: none.
285sub _default_server_bin :Private {
286        my $configured = $ENV{FILESYNC_SERVER_BIN};
287        return $configured if defined $configured && length $configured;
288
289        my $directory = dirname(__FILE__);
290        for (1 .. $SEARCH_DEPTH) {
291                my $candidate = File::Spec->catfile($directory, 'bin', $SERVER_PROGRAM);
292                return $candidate if -f $candidate;
293                $directory = dirname($directory);
294        }
295
296        return $SERVER_PROGRAM;
297
313
313
313
313
91471
309
4196
}
298
2991;
300