… | |
… | |
454 | =cut |
454 | =cut |
455 | |
455 | |
456 | ############################################################################# |
456 | ############################################################################# |
457 | # object support |
457 | # object support |
458 | |
458 | |
|
|
459 | sub reattach { |
|
|
460 | # basically do the same as instantiate, without calling instantiate |
|
|
461 | my ($obj) = @_; |
|
|
462 | |
|
|
463 | my $registry = $obj->registry; |
|
|
464 | |
|
|
465 | @$registry = (); |
|
|
466 | |
|
|
467 | delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; |
|
|
468 | |
|
|
469 | for my $name (keys %{ $obj->{_attachment} || {} }) { |
|
|
470 | if (my $attach = $attachment{$name}) { |
|
|
471 | for (@$attach) { |
|
|
472 | my ($klass, @attach) = @$_; |
|
|
473 | _attach $registry, $klass, @attach; |
|
|
474 | } |
|
|
475 | } else { |
|
|
476 | warn "object uses attachment '$name' that is not available, postponing.\n"; |
|
|
477 | } |
|
|
478 | } |
|
|
479 | } |
|
|
480 | |
459 | cf::attachable->attach ( |
481 | cf::attachable->attach ( |
460 | prio => -1000000, |
482 | prio => -1000000, |
461 | on_instantiate => sub { |
483 | on_instantiate => sub { |
462 | my ($obj, $data) = @_; |
484 | my ($obj, $data) = @_; |
463 | |
485 | |
… | |
… | |
467 | my ($name, $args) = @$_; |
489 | my ($name, $args) = @$_; |
468 | |
490 | |
469 | $obj->attach ($name, %{$args || {} }); |
491 | $obj->attach ($name, %{$args || {} }); |
470 | } |
492 | } |
471 | }, |
493 | }, |
472 | on_reattach => sub { |
494 | on_reattach => \&reattach, |
473 | # basically do the same as instantiate, without calling instantiate |
|
|
474 | my ($obj) = @_; |
|
|
475 | my $registry = $obj->registry; |
|
|
476 | |
|
|
477 | @$registry = (); |
|
|
478 | |
|
|
479 | delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; |
|
|
480 | |
|
|
481 | for my $name (keys %{ $obj->{_attachment} || {} }) { |
|
|
482 | if (my $attach = $attachment{$name}) { |
|
|
483 | for (@$attach) { |
|
|
484 | my ($klass, @attach) = @$_; |
|
|
485 | _attach $registry, $klass, @attach; |
|
|
486 | } |
|
|
487 | } else { |
|
|
488 | warn "object uses attachment '$name' that is not available, postponing.\n"; |
|
|
489 | } |
|
|
490 | } |
|
|
491 | }, |
|
|
492 | on_clone => sub { |
495 | on_clone => sub { |
493 | my ($src, $dst) = @_; |
496 | my ($src, $dst) = @_; |
494 | |
497 | |
495 | @{$dst->registry} = @{$src->registry}; |
498 | @{$dst->registry} = @{$src->registry}; |
496 | |
499 | |