view release on metacpan or  search on metacpan

lib/CTK/App.pm  view on Meta::CPAN

See C<TODO> file

=head1 BUGS

* none noted

=head1 SEE ALSO

L<CTK>, L<CTK::Helper>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See C<LICENSE> file and L<https://dev.perl.org/licenses/>

=cut

use vars qw($VERSION);
$VERSION = '1.02';

use base qw/ CTK /;

use Carp;
use CTK::ConfGenUtil qw/lvalue/;

use constant {
        APP_PLUGINS => [qw/
                cli config log
            /],
    };

my %handler_registry;

sub again {
    my $self = shift;
    my $args = $self->origin;
    my $status = $self->load_plugins(@{(APP_PLUGINS)});
    $self->{status} = 0 unless $status;
    my $config = $self->configobj;

    # Autoloading logger (settings data from config only, no use logmode!!)
    my $log_on = lvalue($config->get("logenable")) || lvalue($config->get("logenabled")) || 0;
    if ($log_on && !$args->{no_logger_init}) {
        my $logopts = $args->{logopts} || {};
        my $logfile = defined($args->{logfile}) ? $self->logfile : lvalue($config->get("logfile")); # From args or config
        $logopts->{facility} = $args->{logfacility} if defined($args->{logfacility});  # From args only!
        $logopts->{file} = $logfile if defined($logfile) && length($logfile);
        $logopts->{ident} = defined($args->{ident})
            ? $args->{ident}
            : (lvalue($config->get("logident")) // $self->project); # From args or config
        $logopts->{level} = defined($args->{loglevel})
            ? $args->{loglevel}
            : lvalue($config->get("loglevel")); # From args or config
        $self->logger_init(%$logopts) or do {
            $self->error("Can't initialize logger");
            $self->{status} = 0;
        };
    }

    return $self;
}

sub register_handler {
    my $class = shift;
    $class = ref($class) if ref($class);
    my %info = @_;
    $handler_registry{$class} = {} unless exists($handler_registry{$class});
    my $handlers = $handler_registry{$class};

    # Handler data
    my $name = $info{handler} // $info{name} // '';
    croak("Incorrect handler name") unless length($name);
    delete $info{handler};
    $info{name} = $name;
    croak("The $name duplicate handler definition")
        if defined($handlers->{$name});
    $info{description} //= '';
    my $params = $info{parameters} || $info{params} || {};
    delete $info{parameters};
    $params = {} unless ref($params) eq "HASH";
    $info{params} = $params;
    my $code = $info{code} || sub {return 1};
    if (ref($code) eq 'CODE') {
        $info{code} = $code;
    } else {
        $info{code} = sub { $code };
    }

    $handlers->{$name} = {%info};
    return 1;
}
sub lookup_handler {
    my $self = shift;
    my $name = shift;
    return undef unless $name;
    my $invocant = ref($self) || scalar(caller(0));
    my $handlers = $handler_registry{$invocant};
    return undef unless $handlers;
    return $handlers->{$name}
}
sub list_handlers {
    my $self = shift;
    my $invocant = ref($self) || scalar(caller(0));
    my $handlers = $handler_registry{$invocant};
    return () unless $handlers && ref($handlers) eq 'HASH';
    return (sort {$a cmp $b} keys %$handlers);
}
sub handle {
    my $self = shift;
    my $meta = shift;