2 * Copyright (c) Zmanda, Inc. All Rights Reserved.
4 * This library is free software; you can redistribute it and/or modify it
5 * under the terms of the GNU Lesser General Public License version 2.1
6 * as published by the Free Software Foundation.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
10 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
11 * License for more details.
13 * You should have received a copy of the GNU Lesser General Public License
14 * along with this library; if not, write to the Free Software Foundation,
15 * Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
17 * Contact information: Zmanda Inc., 465 S Mathlida Ave, Suite 300
18 * Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
21 %module "Amanda::Xfer"
22 %include "amglue/amglue.swg"
23 %include "exception.i"
24 %import "Amanda/MainLoop.swg"
25 %import "Amanda/Device.swg"
28 #include "glib-util.h"
35 Amanda::Xfer - the transfer architecture
40 use Amanda::Xfer qw( :constants );
43 my $infd = POSIX::open("input", POSIX::O_RDONLY, 0);
44 my $outfd = POSIX::open("output", POSIX::O_CREAT|POSIX::O_WRONLY, 0640);
45 my $xfer = Amanda::Xfer->new([
46 Amanda::Xfer::Source::Fd->new($infd),
47 Amanda::Xfer::Dest::Fd->new($outfd)
49 $xfer->get_source()->set_callback(sub {
50 my ($src, $xmsg, $xfer) = @_;
51 print "Message from $xfer: $xmsg\n"; # use stringify operations
52 if ($xfer->get_status() == $XFER_DONE) {
54 Amanda::MainLoop::quit();
58 Amanda::MainLoop::run();
60 See L<http://wiki.zmanda.com/index.php/XFA> for background on the transfer
67 =head1 Amanda::Xfer Objects
69 A new transfer is created with C<< Amanda::Xfer->new() >>, which takes an arrayref
70 giving the transfer elements which should compose the transfer.
72 The resulting object has the following methods:
78 Get the L<Amanda::MainLoop> event source through which messages will be
79 delivered for this transfer. Use its C<set_callback> method to connect a perl
80 sub for processing events. You I<must> C<release> the source when the
83 The callback from this event source receives three arguments: the event source,
84 the message, and a reference to the controlling transfer. See the description of
85 C<Amanda::Xfer::Msg>, below, for details.
89 Start this transfer. Processing takes place asynchronously, and messages will
90 begin queueing up immediately.
94 Stop transferring data. The transfer will send an C<XMSG_CANCEL>, "drain" any
95 buffered data as best it can, and then complete normally with an C<XMSG_DONE>.
99 Get the transfer's status. The result will be one of C<$XFER_INIT>,
100 C<$XFER_START>, C<$XFER_RUNNING>, or C<$XFER_DONE>. These symbols are
101 available for import with the tag C<:constants>.
105 Return a string representation of this transfer, suitable for use in debugging
106 messages. This method is automatically invoked when a transfer is interpolated
108 print "Starting $xfer\n";
112 =head1 Amanda::Xfer::Element objects
114 The individual transfer elements that compose a transfer are instances of
115 subclasses of Amanda::Xfer::Element. All such objects have a C<repr()> method,
116 similar to that for transfers, and support a similar kind of string
119 Note that the names of these classes contain the words "Source", "Filter", and
120 "Dest". This is merely suggestive of their intended purpose -- there are no
121 such abstract classes.
123 =head2 Transfer Sources
125 =head3 Amanda::Xfer::Source::Device
127 Amanda::Xfer::Source::Device->new($device);
129 This source reads data from a device. The device should already be queued up
130 for reading (C<$device->seek_file(..)>). The element will read until the end
133 =head3 Amanda::Xfer::Source::Fd
135 Amanda::Xfer::Source::Fd->new(fileno($fh));
137 This source reads data from a file descriptor. It reads until EOF, but does
138 not close the descriptor. Be careful not to let Perl close the file for you!
140 =head3 Amanda::Xfer::Source::Random
142 Amanda::Xfer::Source::Random->new($length, $seed);
144 This source provides I<length> bytes of random data (or an unlimited amount
145 of data if I<length> is zero). C<$seed> is the seed used
146 to generate the random numbers; this seed can be used in a destination to
147 check for correct output.
149 =head3 Amanda::Xfer::Source::Pattern
151 Amanda::Xfer::Source::Pattern->new($length, $pattern);
153 This source provides I<length> bytes containing copies of
154 I<pattern>. If I<length> is zero, the source provides an unlimited
157 =head2 Transfer Filters
159 =head3 Amanda::Xfer::Filter:Xor
161 Amanda::Xfer::Filter::Xor->new($key);
163 This filter applies a bytewise XOR operation to the data flowing through it.
165 =head2 Transfer Destinations
167 =head3 Amanda::Xfer::Dest::Device
169 Amanda::Xfer::Dest::Device->new($device, $max_memory);
171 This source writes data to a device. The device should already be queued up
172 for writing (C<$device->start_file(..)>). No more than C<$max_memory> will be
173 used for buffers. Use zero for the default buffer size. On completion of the
174 transfer, the file will be finished.
176 =head3 Amanda::Xfer::Dest::Fd
178 Amanda::Xfer::Dest::Fd->new(fileno($fh));
180 This destination writes data to a file descriptor. The file is not closed
181 after the transfer is completed. Be careful not to let Perl close the file
184 =head3 Amanda::Xfer::Dest::Null
186 Amanda::Xfer::Dest::Null->new($seed);
188 This destination discards the data it receives. If C<$seed> is nonzero, then
189 the element will validate that it receives the data that
190 C<Amanda::Xfer::Source::Random> produced with the same seed. No validation is
191 performed if C<$seed> is zero.
193 =head1 Amanda::Xfer::Msg objects
195 Messages are simple hashrefs, with a few convenience methods. Like transfers,
196 they have a C<repr()> method that formats the message nicely, and is available
197 through string interpolation:
198 print "Received message $msg\n";
200 Every message has the following keys:
206 The message type -- one of the C<xmsg_type> constants available from the import
211 The transfer element that sent the message.
215 The version of the message. This is used to support extensibility of the protocol.
219 The canonical description of the message types and keys is in C<xfer-src/xmsg.h>, and is
225 /* The SWIGging of the transfer architecture.
227 * The C layer of the transfer architecture exposes some structs, which are
228 * arranged through GObject magic into a class hierarchy. It also exposes
229 * regular C functions which are intended to act as methods on these structs.
230 * Furthermore, it exposes Perl callbacks (via Amanda::MainLoop) with
231 * parameters involving objects of these classes.
233 * SWIG doesn't support callbacks very well, and makes it particularly
234 * difficult to represent a GObject class hierarchy. Rather than try to "make
235 * it fit" into SWIG, this module uses custom typemaps and perl/C conversions
236 * to get all of this stuff right in the first place.
238 * For Xfer objects, we define two functions, new_sv_for_xfer and xfer_from_sv,
239 * which create a new SV for an Xfer object, and subsequently extract a pointer
240 * to the object from the SV. The SV is both blessed and tied to the
241 * Amanda::Xfer::Xfer class, in which all of the method calls are defined, and
242 * which defines a DESTROY method that calls xfer_unref.
244 * XferElements are similar, but we have the added challenge of representing
245 * subclasses with appropriate perl subclasses. The solution is to tag each C
246 * class with a perl class name, and use that name when blessing a new SV.
248 * Finally, XMsgs are reflected entirely into perl hashrefs, in the interest of
257 /* We need GType and GThread initialized to use xfers */
265 amglue_add_enum_tag_fns(xfer_status);
266 amglue_add_constant(XFER_INIT, xfer_status);
267 amglue_add_constant(XFER_START, xfer_status);
268 amglue_add_constant(XFER_RUNNING, xfer_status);
269 amglue_add_constant(XFER_DONE, xfer_status);
270 amglue_copy_to_tag(xfer_status, constants);
272 amglue_add_enum_tag_fns(xmsg_type);
273 amglue_add_constant(XMSG_INFO, xmsg_type);
274 amglue_add_constant(XMSG_ERROR, xmsg_type);
275 amglue_add_constant(XMSG_DONE, xmsg_type);
276 amglue_add_constant(XMSG_CANCEL, xmsg_type);
277 amglue_copy_to_tag(xmsg_type, constants);
284 /* Return a new SV with refcount 1 representing the given C object
285 * with the given class.
287 * @param c_obj: the object to represent
288 * @param perl_class: the perl with which to bless and tie the SV
293 const char *perl_class)
297 /* Make an SV that contains a pointer to the object, and bless it
298 * with the appropriate class. */
299 sv_setref_pv(sv, perl_class, c_obj);
304 /* Return a new SV representing a transfer.
306 * @param xfer: the transfer to represent
312 if (!xfer) return &PL_sv_undef;
315 return new_sv_for_c_obj(xfer, "Amanda::Xfer::Xfer");
318 /* Return a new SV representing a transfer element.
320 * @param xe: the transfer element to represent
323 new_sv_for_xfer_element(
326 const char *perl_class;
328 if (!xe) return &PL_sv_undef;
330 perl_class = XFER_ELEMENT_GET_CLASS(xe)->perl_class;
331 if (!perl_class) die("Attempt to wrap an XferElementClass with no perl class!");
333 return new_sv_for_c_obj(xe, perl_class);
336 /* Return the C object buried in an SV, asserting that the perl SV is
337 * derived from derived_from. Returns NULL for undefined perl values.
339 * This function is based on SWIG's SWIG_Perl_ConvertPtr. The INT2PTR
340 * situation certainly looks strange, but is documented in perlxs.
342 * @param sv: the SV to convert
343 * @param derived_from: perl class from which the SV should be derived
344 * @return: underlying pointer
349 const char *derived_from)
354 if (!sv) return NULL;
355 if (!SvOK(sv)) return NULL;
357 /* Peel back the layers. The sv should be a blessed reference to a PV,
358 * and we check the class against derived_from to ensure we have the right
360 if (!sv_isobject(sv) || !sv_derived_from(sv, derived_from)) {
361 croak("Value is not an object of type %s", derived_from);
365 referent = (SV *)SvRV(sv);
366 tmp = SvIV(referent);
367 return INT2PTR(gpointer, tmp);
370 /* Convert an SV to an Xfer. The Xfer's reference count is not
371 * incremented -- this is a "borrowed" reference.
373 * @param sv: the perl value
374 * @returns: pointer to the corresponding transfer, or NULL
380 return (Xfer *)c_obj_from_sv(sv, "Amanda::Xfer::Xfer");
383 /* Convert an SV to an XferElement. The element's reference count is
384 * not incremented -- this is a "borrowed" reference.
386 * @param sv: the perl value
387 * @returns: pointer to the corresponding transfer element, or NULL.
390 xfer_element_from_sv(
393 return (XferElement *)c_obj_from_sv(sv, "Amanda::Xfer::Element");
396 /* Given an XMsg, return a hashref representing the message as a pure-perl
397 * object. The object is new, has refcount 1, and is totally independent of
398 * the underlying XMsg.
400 * Reflecting the XMsg directly into Perl avoids the need to reference-count
401 * the XMsg objects themselves, which can simply be freed after a callback
402 * completes. The overhead of creating a hash is likely equivalent to or
403 * less than the overhead that would be consumed with SWIG's swig_$field_get
404 * accessors, assuming that perl code examines most of the fields in a message.
406 * @param msg: the message to represent
407 * @returns: a perl SV
413 static HV *amanda_xfer_msg_stash = NULL;
415 SV *rv = newRV_noinc((SV *)hash);
417 /* bless the rv as an Amanda::Xfer::Msg object */
418 if (!amanda_xfer_msg_stash) {
419 amanda_xfer_msg_stash = gv_stashpv("Amanda::Xfer::Msg", GV_ADD);
421 sv_bless(rv, amanda_xfer_msg_stash);
423 /* TODO: consider optimizing by precomputing the hash values of
427 hv_store(hash, "elt", 3, new_sv_for_xfer_element(msg->elt), 0);
430 hv_store(hash, "type", 4, newSViv(msg->type), 0);
433 hv_store(hash, "version", 7, newSViv(msg->version), 0);
437 hv_store(hash, "message", 7, newSVpv(msg->message, 0), 0);
443 %typemap(in) Xfer * {
444 $1 = xfer_from_sv($input);
447 %typemap(in) XferElement * {
448 $1 = xfer_element_from_sv($input);
451 %typemap(out) Xfer * {
452 $result = sv_2mortal(new_sv_for_xfer($1));
456 %typemap(out) XferElement * {
457 $result = sv_2mortal(new_sv_for_xfer_element($1));
461 %typemap(newfree) Xfer * {
465 %typemap(newfree) XferElement * {
466 xfer_element_unref($1);
473 /* A typemap for the input to the Xfer constructor, a.k.a. xfer_new */
474 %typemap(in,numinputs=1) (XferElement **elementlist, unsigned int nelements) {
478 /* check that it's an arrayref */
479 if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
480 SWIG_exception(SWIG_TypeError, "Expected an arrayref");
482 av = (AV *)SvRV($input);
484 /* allocate memory for $1 */
485 $2 = av_len(av)+1; /* av_len(av) is like $#av */
486 $1 = g_new(XferElement *, $2);
488 /* extract the underlying XferElement objects and add pointers to
489 * them, "borrowing" the caller's references for the moment. */
490 for (i = 0; i < $2; i++) {
491 SV **sv = av_fetch(av, i, 0);
492 XferElement *elt = sv? xfer_element_from_sv(*sv):NULL;
495 SWIG_exception(SWIG_TypeError, "Expected an arrayref of Amanda::Xfer::Element objects");
501 %typemap(freearg) (XferElement **elementlist, unsigned int nelements) {
502 /* free the element vector allocated in the (in) typemap */
507 Xfer *xfer_new(XferElement **elementlist, unsigned int nelements);
508 void xfer_unref(Xfer *);
509 xfer_status xfer_get_status(Xfer *xfer);
510 char *xfer_repr(Xfer *xfer);
511 void xfer_start(Xfer *xfer);
512 void xfer_cancel(Xfer *xfer);
513 /* xfer_get_source is implemented below */
516 /* SWIG wants to treat this as a function */
517 #define xfer_get_status(xfer) ((xfer)->status)
521 * XferElement functions
523 * Some of these methods are not intended to be used from Perl; they are annotated
527 void xfer_element_unref(XferElement *elt); /* (wrap the macro, above) */
528 /* xfer_element_link_to -- private */
529 char *xfer_element_repr(XferElement *elt);
530 /* xfer_element_start -- private */
531 /* xfer_element_cancel -- private */
533 /* subclass constructors */
535 /* N.B. When adding new classes, ensure that the class_init function
536 * sets perl_class to the appropriate value. */
538 %newobject xfer_source_device;
539 XferElement *xfer_source_device(
542 %newobject xfer_source_random;
543 XferElement *xfer_source_random(
547 %typemap(in) (void * pattern, size_t pattern_length) {
551 pat = SvPV($input, len);
552 $1 = g_memdup(pat, len);
556 %newobject xfer_source_random;
557 XferElement *xfer_source_pattern(
560 size_t pattern_length);
562 %newobject xfer_source_fd;
563 XferElement *xfer_source_fd(
566 %newobject xfer_filter_xor;
567 XferElement *xfer_filter_xor(
568 unsigned char xor_key);
570 %newobject xfer_dest_device;
571 XferElement *xfer_dest_device(
575 %newobject xfer_dest_null;
576 XferElement *xfer_dest_null(
579 %newobject xfer_dest_fd;
580 XferElement *xfer_dest_fd(
587 %types(amglue_Source *);
590 xmsgsource_perl_callback(
596 amglue_Source *src = (amglue_Source *)data;
599 g_assert(src->callback_sv != NULL);
604 /* create a new SV pointing to 'src', and increase its refcount
605 * accordingly. The SV is mortal, so FREETMPS will decrease the
606 * refcount, unless the callee keeps a copy of it somewhere */
607 amglue_source_ref(src);
608 src_sv = SWIG_NewPointerObj(src, SWIGTYPE_p_amglue_Source,
609 SWIG_OWNER | SWIG_SHADOW);
613 XPUSHs(sv_2mortal(new_sv_for_xmsg(msg)));
614 XPUSHs(sv_2mortal(new_sv_for_xfer(xfer)));
617 call_sv(src->callback_sv, G_EVAL|G_DISCARD);
622 /* these may have been freed, so don't use them after this point */
626 /* check for an uncaught 'die'. If we don't do this, then Perl will longjmp()
627 * over the GMainLoop mechanics, leaving GMainLoop in an inconsistent (locked)
630 /* We handle this just the way the default 'die' handler in Amanda::Debug
631 * does, but since Amanda's debug support may not yet be running, we back
632 * it up with an exit() */
633 g_critical("%s", SvPV_nolen(ERRSV));
641 %newobject xfer_get_amglue_source;
644 xfer_get_amglue_source(
647 return amglue_source_get(xfer_get_source(xfer),
648 (GSourceFunc)xmsgsource_perl_callback);
653 * XMsg and XMsgSource handling
660 /* First, a few macros to generate decent Perl */
668 %define XFER_ELEMENT_SUBCLASS()
671 @ISA = qw( Amanda::Xfer::Element );
675 %define DECLARE_CONSTRUCTOR(C_CONSTRUCTOR)
679 # The C function adds the proper blessing -- this function
680 # just gets $pkg out of the way.
681 Amanda::Xfer::C_CONSTRUCTOR(@_);
686 %define OVERLOAD_REPR()
687 %perlcode {use overload '""' => sub { $_[0]->repr(); };
691 %define DECLARE_METHOD(METHOD_NAME, C_FUNCTION)
692 %perlcode {*METHOD_NAME = *Amanda::Xfer::C_FUNCTION;
696 /* And now define the required perl classes */
698 PACKAGE(Amanda::Xfer::Xfer)
699 DECLARE_CONSTRUCTOR(xfer_new);
700 DECLARE_METHOD(DESTROY, xfer_unref);
702 DECLARE_METHOD(repr, xfer_repr);
703 DECLARE_METHOD(get_status, xfer_get_status);
704 DECLARE_METHOD(get_source, xfer_get_amglue_source);
705 DECLARE_METHOD(start, xfer_start);
706 DECLARE_METHOD(cancel, xfer_cancel);
710 PACKAGE(Amanda::Xfer::Element)
711 DECLARE_METHOD(DESTROY, xfer_element_unref);
713 DECLARE_METHOD(repr, xfer_element_repr);
717 PACKAGE(Amanda::Xfer::Element::Glue)
718 XFER_ELEMENT_SUBCLASS()
719 /* no constructor -- internal use only */
723 PACKAGE(Amanda::Xfer::Source::Device)
724 XFER_ELEMENT_SUBCLASS()
725 DECLARE_CONSTRUCTOR(xfer_source_device)
729 PACKAGE(Amanda::Xfer::Source::Fd)
730 XFER_ELEMENT_SUBCLASS()
731 DECLARE_CONSTRUCTOR(xfer_source_fd)
735 PACKAGE(Amanda::Xfer::Source::Random)
736 XFER_ELEMENT_SUBCLASS()
737 DECLARE_CONSTRUCTOR(xfer_source_random)
741 PACKAGE(Amanda::Xfer::Source::Pattern)
742 XFER_ELEMENT_SUBCLASS()
743 DECLARE_CONSTRUCTOR(xfer_source_pattern)
747 PACKAGE(Amanda::Xfer::Filter::Xor)
748 XFER_ELEMENT_SUBCLASS()
749 DECLARE_CONSTRUCTOR(xfer_filter_xor)
753 PACKAGE(Amanda::Xfer::Dest::Device)
754 XFER_ELEMENT_SUBCLASS()
755 DECLARE_CONSTRUCTOR(xfer_dest_device)
759 PACKAGE(Amanda::Xfer::Dest::Fd)
760 XFER_ELEMENT_SUBCLASS()
761 DECLARE_CONSTRUCTOR(xfer_dest_fd)
765 PACKAGE(Amanda::Xfer::Dest::Null)
766 XFER_ELEMENT_SUBCLASS()
767 DECLARE_CONSTRUCTOR(xfer_dest_null)
771 PACKAGE(Amanda::Xfer::Msg)
774 use overload '""' => sub { $_[0]->repr(); };
778 local $Data::Dumper::Indent = 0;
779 local $Data::Dumper::Terse = 1;
780 local $Data::Dumper::Useqq = 1;
782 my $typestr = Amanda::Xfer::xmsg_type_to_string($self->{'type'});
783 my $str = "{ type => \$$typestr, elt => $self->{'elt'}, version => $self->{'version'},";
785 my %skip = ( "type" => 1, "elt" => 1, "version" => 1 );
786 for my $k (keys %$self) {
788 $str .= " $k => " . Dumper($self->{$k}) . ",";
791 # strip the trailing comma and add a closing brace
800 PACKAGE(Amanda::Xfer)
802 # make Amanda::Xfer->new equivalent to Amanda::Xfer::Xfer->new (don't
803 # worry, the blessings work out just fine)
804 *new = *Amanda::Xfer::Xfer::new;