1/*
2 * Copyright (c) 2008-2013 Zmanda, Inc.  All Rights Reserved.
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
11 * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
12 * for more details.
13 *
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
17 *
18 * Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300
19 * Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
20 */
21
22%module "Amanda::Xfer"
23%include "amglue/amglue.swg"
24%include "exception.i"
25%include "cstring.i"
26%import "Amanda/MainLoop.swg"
27
28%include "Xfer.pod"
29
30%{
31#include "glib-util.h"
32#include "amxfer.h"
33#include "amanda.h"
34#include "sockaddr-util.h"
35%}
36
37/* The SWIGging of the transfer architecture.
38 *
39 * The C layer of the transfer architecture exposes some structs, which are
40 * arranged through GObject magic into a class hierarchy.  It also exposes
41 * regular C functions which are intended to act as methods on these structs.
42 * Furthermore, it exposes Perl callbacks (via Amanda::MainLoop) with
43 * parameters involving objects of these classes.
44 *
45 * SWIG doesn't support callbacks very well, and makes it particularly
46 * difficult to represent a GObject class hierarchy.  Rather than try to "make
47 * it fit" into SWIG, this module uses custom typemaps and perl/C conversions
48 * to get all of this stuff right in the first place.
49 *
50 * For Xfer objects, we define two functions, new_sv_for_xfer and xfer_from_sv,
51 * which create a new SV for an Xfer object, and subsequently extract a pointer
52 * to the object from the SV.  The SV is both blessed and tied to the
53 * Amanda::Xfer::Xfer class, in which all of the method calls are defined, and
54 * which defines a DESTROY method that calls xfer_unref.
55 *
56 * XferElements are similar, but we have the added challenge of representing
57 * subclasses with appropriate perl subclasses.  The solution is to tag each C
58 * class with a perl class name, and use that name when blessing a new SV.
59 *
60 * Finally, XMsgs are reflected entirely into perl hashrefs, in the interest of
61 * efficiency.
62 */
63
64/*
65 * Initialization
66 */
67
68%init %{
69    /* We need GType and GThread initialized to use xfers */
70    glib_init();
71%}
72
73/*
74 * Constants
75 */
76
77amglue_add_enum_tag_fns(xfer_status);
78amglue_add_constant(XFER_INIT, xfer_status);
79amglue_add_constant(XFER_START, xfer_status);
80amglue_add_constant(XFER_RUNNING, xfer_status);
81amglue_add_constant(XFER_DONE, xfer_status);
82amglue_copy_to_tag(xfer_status, constants);
83
84amglue_add_enum_tag_fns(xmsg_type);
85amglue_add_constant(XMSG_INFO, xmsg_type);
86amglue_add_constant(XMSG_ERROR, xmsg_type);
87amglue_add_constant(XMSG_DONE, xmsg_type);
88amglue_add_constant(XMSG_CANCEL, xmsg_type);
89amglue_add_constant(XMSG_PART_DONE, xmsg_type);
90amglue_add_constant(XMSG_READY, xmsg_type);
91amglue_copy_to_tag(xmsg_type, constants);
92
93/*
94 * Wrapping machinery
95 */
96
97%{
98/* Given an XMsg, return a hashref representing the message as a pure-perl
99 * object.  The object is new, has refcount 1, and is totally independent of
100 * the underlying XMsg.
101 *
102 * Reflecting the XMsg directly into Perl avoids the need to reference-count
103 * the XMsg objects themselves, which can simply be freed after a callback
104 * completes.  The overhead of creating a hash is likely equivalent to or
105 * less than the overhead that would be consumed with SWIG's swig_$field_get
106 * accessors, assuming that perl code examines most of the fields in a message.
107 *
108 * @param msg: the message to represent
109 * @returns: a perl SV
110 */
111static SV *
112new_sv_for_xmsg(
113    XMsg *msg)
114{
115    static HV *amanda_xfer_msg_stash = NULL;
116    HV *hash = newHV();
117    SV *rv = newRV_noinc((SV *)hash);
118
119    /* bless the rv as an Amanda::Xfer::Msg object */
120    if (!amanda_xfer_msg_stash) {
121	amanda_xfer_msg_stash = gv_stashpv("Amanda::Xfer::Msg", GV_ADD);
122    }
123    sv_bless(rv, amanda_xfer_msg_stash);
124
125    /* TODO: consider optimizing by precomputing the hash values of
126     * the keys? */
127
128    /* elt */
129    hv_store(hash, "elt", 3, new_sv_for_xfer_element(msg->elt), 0);
130
131    /* type */
132    hv_store(hash, "type", 4, newSViv(msg->type), 0);
133
134    /* type */
135    hv_store(hash, "version", 7, newSViv(msg->version), 0);
136
137    /* message */
138    if (msg->message)
139	hv_store(hash, "message", 7, newSVpv(msg->message, 0), 0);
140
141    /* successful */
142    hv_store(hash, "successful", 10, newSViv(msg->successful), 0);
143
144    /* eom */
145    hv_store(hash, "eom", 3, newSViv(msg->eom), 0);
146
147    /* eof */
148    hv_store(hash, "eof", 3, newSViv(msg->eof), 0);
149
150    /* size */
151    hv_store(hash, "size", 4, amglue_newSVu64(msg->size), 0);
152
153    /* duration */
154    hv_store(hash, "duration", 8, newSVnv(msg->duration), 0);
155
156    /* partnum */
157    hv_store(hash, "partnum", 7, amglue_newSVu64(msg->partnum), 0);
158
159    /* fileno */
160    hv_store(hash, "fileno", 6, amglue_newSVu64(msg->fileno), 0);
161
162    return rv;
163}
164%}
165
166%typemap(in) Xfer * {
167    $1 = xfer_from_sv($input);
168}
169
170%typemap(in) XferElement * {
171    $1 = xfer_element_from_sv($input);
172}
173
174%typemap(out) Xfer * {
175    $result = sv_2mortal(new_sv_for_xfer($1));
176    argvi++;
177}
178
179%typemap(out) XferElement * {
180    $result = sv_2mortal(new_sv_for_xfer_element($1));
181    argvi++;
182}
183
184%typemap(newfree) Xfer * {
185    xfer_unref($1);
186}
187
188%typemap(newfree) XferElement * {
189    xfer_element_unref($1);
190}
191
192/*
193 * Xfer functions
194 */
195
196/* A typemap for the input to the Xfer constructor, a.k.a. xfer_new */
197%typemap(in,numinputs=1) (XferElement **elementlist, unsigned int nelements) {
198    AV *av;
199    unsigned int i;
200
201    /* check that it's an arrayref */
202    if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
203	SWIG_exception(SWIG_TypeError, "Expected an arrayref");
204    }
205    av = (AV *)SvRV($input);
206
207    /* allocate memory for $1 */
208    $2 = av_len(av)+1; /* av_len(av) is like $#av */
209    $1 = g_new(XferElement *, $2);
210
211    /* extract the underlying XferElement objects and add pointers to
212     * them, "borrowing" the caller's references for the moment. */
213    for (i = 0; i < $2; i++) {
214	SV **sv = av_fetch(av, i, 0);
215	XferElement *elt = sv? xfer_element_from_sv(*sv):NULL;
216
217	if (!elt) {
218	    SWIG_exception(SWIG_TypeError, "Expected an arrayref of Amanda::Xfer::Element objects");
219	}
220	$1[i] = elt;
221    }
222}
223
224%typemap(freearg) (XferElement **elementlist, unsigned int nelements) {
225    /* free the element vector allocated in the (in) typemap */
226    g_free($1);
227}
228
229%newobject xfer_new;
230Xfer *xfer_new(XferElement **elementlist, unsigned int nelements);
231void xfer_unref(Xfer *);
232xfer_status xfer_get_status(Xfer *xfer);
233char *xfer_repr(Xfer *xfer);
234void xfer_start(Xfer *xfer, gint64 offset, gint64 size);
235void xfer_cancel(Xfer *xfer);
236/* xfer_get_source is implemented below */
237
238%inline %{
239/* SWIG wants to treat this as a function */
240#define xfer_get_status(xfer) ((xfer)->status)
241%}
242
243/* upgrade the start method to optionally take a callback, which is
244 * passed to the GSource's set_callback */
245%perlcode %{
246sub xfer_start_with_callback {
247    my ($xfer, $cb, $offset, $size) = @_;
248    if (defined $cb) {
249	my $releasing_cb = sub {
250	    my ($src, $msg, $xfer) = @_;
251	    my $done = $msg->{'type'} == $XMSG_DONE;
252	    $src->remove() if $done;
253	    $cb->(@_);
254	    $cb = undef if $done; # break potential reference loop
255	};
256	$xfer->get_source()->set_callback($releasing_cb);
257    }
258    $offset = 0 if !defined $offset;
259    $size = 0 if !defined $size;
260    xfer_start($xfer, $offset, $size);
261}
262%}
263
264/* Change the callback */
265%perlcode %{
266sub xfer_set_callback {
267    my ($xfer, $cb) = @_;
268    if (defined $cb) {
269	my $releasing_cb = sub {
270	    my ($src, $msg, $xfer) = @_;
271	    my $done = $msg->{'type'} == $XMSG_DONE;
272	    $src->remove() if $done;
273	    $cb->(@_);
274	    $cb = undef if $done; # break potential reference loop
275       };
276	$xfer->get_source()->set_callback($releasing_cb);
277    } else {
278	$xfer->get_source()->set_callback(undef);
279    }
280}
281%}
282
283/*
284 * XferElement functions
285 *
286 * Some of these methods are not intended to be used from Perl; they are annotated
287 * as "private".
288 */
289
290void xfer_element_unref(XferElement *elt); /* (wrap the macro, above) */
291/* xfer_element_link_to -- private */
292char *xfer_element_repr(XferElement *elt);
293/* xfer_element_set_size -- private */
294/* xfer_element_start -- private */
295/* xfer_element_cancel -- private */
296
297%inline %{
298static gboolean same_elements(
299	XferElement *a,
300	XferElement *b)
301{
302    return a == b;
303}
304%}
305
306/* subclass constructors */
307
308/* N.B. When adding new classes, ensure that the class_init function
309 * sets perl_class to the appropriate value. */
310
311%newobject xfer_source_random;
312XferElement *xfer_source_random(
313    guint64 length,
314    guint32 seed);
315
316guint32 xfer_source_random_get_seed(
317    XferElement *self);
318
319%typemap(in) (void * pattern, size_t pattern_length) {
320 size_t len;
321 char * pat;
322
323 pat = SvPV($input, len);
324 $1 = g_memdup(pat, len);
325 $2 = len;
326}
327
328%typemap(in) (gchar **argv) {
329    AV *av;
330    unsigned int len;
331    unsigned int i;
332
333    /* check that it's an arrayref */
334    if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
335	SWIG_exception(SWIG_TypeError, "Expected a non-empty arrayref");
336    }
337    av = (AV *)SvRV($input);
338
339    /* allocate memory for $1 */
340    len = av_len(av)+1; /* av_len(av) is like $#av */
341    if (!len) {
342	SWIG_exception(SWIG_TypeError, "Expected a non-empty arrayref");
343    }
344    $1 = g_new0(gchar *, len+1);
345
346    for (i = 0; i < len; i++) {
347	SV **sv = av_fetch(av, i, 0);
348	g_assert(sv != NULL);
349	$1[i] = g_strdup(SvPV_nolen(*sv));
350    }
351
352    /* final element is already NULL due to g_new0; xfer_filter_process takes
353     * care of freeing this array, so we don't have to */
354}
355
356%newobject xfer_source_pattern;
357XferElement *xfer_source_pattern(
358    guint64 length,
359    void * pattern,
360    size_t pattern_length);
361
362%newobject xfer_source_fd;
363XferElement *xfer_source_fd(
364    int fd);
365
366%newobject xfer_source_directtcp_listen;
367XferElement *xfer_source_directtcp_listen(void);
368
369%inline %{
370static DirectTCPAddr *
371xfer_source_directtcp_listen_get_addrs(XferElement *elt) {
372    return elt->input_listen_addrs;
373}
374%}
375
376%newobject xfer_source_directtcp_connect;
377XferElement *xfer_source_directtcp_connect(DirectTCPAddr *addrs);
378
379%newobject xfer_filter_xor;
380XferElement *xfer_filter_xor(
381    unsigned char xor_key);
382
383%newobject xfer_filter_process;
384XferElement *xfer_filter_process(
385    gchar **argv,
386    gboolean need_root,
387    gboolean must_drain,
388    gboolean cancel_on_success,
389    gboolean ignore_broken_pipe);
390int get_err_fd(
391    XferElement *elt);
392
393%newobject xfer_dest_null;
394XferElement *xfer_dest_null(
395    guint32 prng_seed);
396
397%newobject xfer_dest_buffer;
398XferElement *xfer_dest_buffer(
399    gsize max_size);
400
401%cstring_output_allocate_size(gpointer *buf, gsize *size, );
402void xfer_dest_buffer_get(
403    XferElement *elt,
404    gpointer *buf,
405    gsize *size);
406
407%newobject xfer_dest_fd;
408XferElement *xfer_dest_fd(
409    int fd);
410
411%newobject xfer_dest_directtcp_listen;
412XferElement *xfer_dest_directtcp_listen(void);
413
414%inline %{
415static DirectTCPAddr *
416xfer_dest_directtcp_listen_get_addrs(XferElement *elt) {
417    return elt->output_listen_addrs;
418}
419%}
420
421%newobject xfer_dest_directtcp_connect;
422XferElement *xfer_dest_directtcp_connect(DirectTCPAddr *addrs);
423
424/*
425 * Callback handling
426 */
427
428%types(amglue_Source *);
429%{
430static gboolean
431xmsgsource_perl_callback(
432    gpointer data,
433    struct XMsg *msg,
434    Xfer *xfer)
435{
436    dSP;
437    amglue_Source *src = (amglue_Source *)data;
438    SV *src_sv = NULL;
439    SV *msg_sv = NULL;
440    SV *xfer_sv = NULL;
441
442    /* keep the source around long enough for the call to finish */
443    amglue_source_ref(src);
444    g_assert(src->callback_sv != NULL);
445
446    ENTER;
447    SAVETMPS;
448
449    /* create a new SV pointing to 'src', and increase its refcount
450     * accordingly. */
451    amglue_source_ref(src);
452    src_sv = SWIG_NewPointerObj(src, SWIGTYPE_p_amglue_Source,
453				 SWIG_OWNER | SWIG_SHADOW);
454    SvREFCNT_inc(src_sv);
455
456    msg_sv = new_sv_for_xmsg(msg);
457    xfer_sv = new_sv_for_xfer(xfer);
458
459    PUSHMARK(SP);
460    XPUSHs(sv_2mortal(src_sv));
461    XPUSHs(sv_2mortal(msg_sv));
462    XPUSHs(sv_2mortal(xfer_sv));
463    PUTBACK;
464
465    call_sv(src->callback_sv, G_EVAL|G_DISCARD);
466
467    FREETMPS;
468    LEAVE;
469
470    /* we no longer need the src */
471    amglue_source_unref(src);
472    src = NULL;
473
474    /* these may be gone, so NULL them out */
475    src_sv = NULL;
476    msg_sv = NULL;
477    xfer_sv = NULL;
478
479    /* check for an uncaught 'die'.  If we don't do this, then Perl will longjmp()
480     * over the GMainLoop mechanics, leaving GMainLoop in an inconsistent (locked)
481     * state. */
482    if (SvTRUE(ERRSV)) {
483	/* We handle this just the way the default 'die' handler in Amanda::Debug
484	 * does, but since Amanda's debug support may not yet be running, we back
485	 * it up with an exit() */
486	g_critical("%s", SvPV_nolen(ERRSV));
487	exit(1);
488    }
489
490    return TRUE;
491}
492%}
493
494%newobject xfer_get_amglue_source;
495%inline %{
496amglue_Source *
497xfer_get_amglue_source(
498    Xfer *xfer)
499{
500    return amglue_source_get(xfer_get_source(xfer),
501	(GSourceFunc)xmsgsource_perl_callback);
502}
503%}
504
505/*
506 * XMsg and XMsgSource handling
507 */
508
509/*
510 * The perl side
511 */
512
513/* First, a few macros to generate decent Perl */
514
515%define PACKAGE(PKG)
516%perlcode %{
517package PKG;
518%}
519%enddef
520
521%define XFER_ELEMENT_SUBCLASS_OF(PARENT)
522%perlcode %{
523use vars qw(@ISA);
524@ISA = qw( PARENT );
525%}
526%enddef
527
528%define XFER_ELEMENT_SUBCLASS()
529XFER_ELEMENT_SUBCLASS_OF(Amanda::Xfer::Element)
530%enddef
531
532%define DECLARE_CONSTRUCTOR(C_CONSTRUCTOR)
533%perlcode %{
534sub new {
535    my $pkg = shift;
536    # The C function adds the proper blessing -- this function
537    # just gets $pkg out of the way.
538    C_CONSTRUCTOR(@_);
539}
540%}
541%enddef
542
543%define OVERLOAD_REPR()
544%perlcode %{
545use overload '""' => sub { $_[0]->repr(); };
546# overload comparison, so users can ask if one obj == another
547use overload '==' => sub {     Amanda::Xfer::same_elements($_[0], $_[1]); };
548use overload '!=' => sub { not Amanda::Xfer::same_elements($_[0], $_[1]); };
549%}
550%enddef
551
552%define DECLARE_METHOD(METHOD_NAME, C_FUNCTION)
553%perlcode %{ *METHOD_NAME = *C_FUNCTION;
554%}
555%enddef
556
557/* And now define the required perl classes */
558
559PACKAGE(Amanda::Xfer::Xfer)
560DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_new);
561DECLARE_METHOD(DESTROY, Amanda::Xfer::xfer_unref);
562OVERLOAD_REPR()
563DECLARE_METHOD(repr, Amanda::Xfer::xfer_repr);
564DECLARE_METHOD(get_status, Amanda::Xfer::xfer_get_status);
565DECLARE_METHOD(get_source, Amanda::Xfer::xfer_get_amglue_source);
566DECLARE_METHOD(start, Amanda::Xfer::xfer_start_with_callback);
567DECLARE_METHOD(set_callback, Amanda::Xfer::xfer_set_callback);
568DECLARE_METHOD(cancel, Amanda::Xfer::xfer_cancel);
569
570/* ---- */
571
572PACKAGE(Amanda::Xfer::Element)
573DECLARE_METHOD(DESTROY, Amanda::Xfer::xfer_element_unref);
574OVERLOAD_REPR()
575DECLARE_METHOD(repr, Amanda::Xfer::xfer_element_repr);
576
577/* ---- */
578
579PACKAGE(Amanda::Xfer::Element::Glue)
580XFER_ELEMENT_SUBCLASS()
581/* no constructor -- internal use only */
582
583/* ---- */
584
585PACKAGE(Amanda::Xfer::Source::Fd)
586XFER_ELEMENT_SUBCLASS()
587DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_source_fd)
588
589/* ---- */
590
591PACKAGE(Amanda::Xfer::Source::Random)
592XFER_ELEMENT_SUBCLASS()
593DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_source_random)
594DECLARE_METHOD(get_seed, Amanda::Xfer::xfer_source_random_get_seed)
595
596/* ---- */
597
598PACKAGE(Amanda::Xfer::Source::DirectTCPListen)
599XFER_ELEMENT_SUBCLASS()
600DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_source_directtcp_listen)
601DECLARE_METHOD(get_addrs, Amanda::Xfer::xfer_source_directtcp_listen_get_addrs)
602
603/* ---- */
604
605PACKAGE(Amanda::Xfer::Source::DirectTCPConnect)
606XFER_ELEMENT_SUBCLASS()
607DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_source_directtcp_connect)
608
609/* ---- */
610
611PACKAGE(Amanda::Xfer::Source::Pattern)
612XFER_ELEMENT_SUBCLASS()
613DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_source_pattern)
614
615/* ---- */
616
617PACKAGE(Amanda::Xfer::Filter::Xor)
618XFER_ELEMENT_SUBCLASS()
619DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_filter_xor)
620
621/* ---- */
622
623PACKAGE(Amanda::Xfer::Filter::Process)
624XFER_ELEMENT_SUBCLASS()
625DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_filter_process)
626DECLARE_METHOD(get_stderr_fd, Amanda::Xfer::get_err_fd)
627
628/* ---- */
629
630PACKAGE(Amanda::Xfer::Dest::Fd)
631XFER_ELEMENT_SUBCLASS()
632DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_dest_fd)
633
634/* ---- */
635
636PACKAGE(Amanda::Xfer::Dest::Null)
637XFER_ELEMENT_SUBCLASS()
638DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_dest_null)
639
640/* ---- */
641
642PACKAGE(Amanda::Xfer::Dest::Buffer)
643XFER_ELEMENT_SUBCLASS()
644DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_dest_buffer)
645DECLARE_METHOD(get, Amanda::Xfer::xfer_dest_buffer_get)
646
647/* ---- */
648
649PACKAGE(Amanda::Xfer::Dest::DirectTCPListen)
650XFER_ELEMENT_SUBCLASS()
651DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_dest_directtcp_listen)
652DECLARE_METHOD(get_addrs, Amanda::Xfer::xfer_dest_directtcp_listen_get_addrs)
653
654/* ---- */
655
656PACKAGE(Amanda::Xfer::Dest::DirectTCPConnect)
657XFER_ELEMENT_SUBCLASS()
658DECLARE_CONSTRUCTOR(Amanda::Xfer::xfer_dest_directtcp_connect)
659
660/* ---- */
661
662PACKAGE(Amanda::Xfer::Msg)
663%perlcode %{
664use Data::Dumper;
665use overload '""' => sub { $_[0]->repr(); };
666
667sub repr {
668    my ($self) = @_;
669    local $Data::Dumper::Indent = 0;
670    local $Data::Dumper::Terse = 1;
671    local $Data::Dumper::Useqq = 1;
672
673    my $typestr = Amanda::Xfer::xmsg_type_to_string($self->{'type'});
674    my $str = "{ type => \$$typestr, elt => $self->{'elt'}, version => $self->{'version'},";
675
676    my %skip = ( "type" => 1, "elt" => 1, "version" => 1 );
677    for my $k (keys %$self) {
678	next if $skip{$k};
679	$str .= " $k => " . Dumper($self->{$k}) . ",";
680    }
681
682    # strip the trailing comma and add a closing brace
683    $str =~ s/,$/ }/g;
684
685    return $str;
686}
687%}
688
689/* ---- */
690
691PACKAGE(Amanda::Xfer)
692%perlcode %{
693# make Amanda::Xfer->new equivalent to Amanda::Xfer::Xfer->new (don't
694# worry, the blessings work out just fine)
695*new = *Amanda::Xfer::Xfer::new;
696
697# try to load Amanda::XferServer, which is server-only.  If it's not found, then
698# its classes just remain undefined.
699BEGIN {
700    use Amanda::Util;
701    if (Amanda::Util::built_with_component("server")) {
702	eval "use Amanda::XferServer;";
703    }
704}
705%}
706