view release on metacpan or  search on metacpan

lib/UR/ModuleBase.pm  view on Meta::CPAN

            defined($msg) && chomp($msg);

            # old-style callback registered with error_messages_callback
            if (my $code = $self->$check_callback()) {
                if (ref $code) {
                    $code->($self, $msg);
                } else {
                    $self->$code($msg);
                }
            }

            # New-style callback registered as an observer
            # Some non-UR classes inherit from UR::ModuleBase, and can't __signal
            if ($UR::initialized && $self->can('__signal_observers__')) {
                $self->__signal_observers__($logger_subname, $msg);
            }

            $save_setting->($self, $logger_subname, $msg);
            # If the callback set $msg to undef with "$_[1] = undef", then they didn't want the message
            # processed further
            if (defined $msg) {
                if ($self->$should_queue_messages()) {
                    my $a = $self->$messages_arrayref();
                    push @$a, $msg;
                }

                my ($package, $file, $line, $subroutine) = caller;
                $self->$message_package($package);
                $self->$message_file($file);
                $self->$message_line($line);
                $self->$message_subroutine($subroutine);

                $self->$messaging_action($msg);

            }
        }

        return $get_setting->($self, $logger_subname);
    };
    Sub::Install::install_sub({
        code => $logger_subref,
        into => $class,
        as => $logger_subname,
    });

    # "Register" the message type as a valid signal.
    $UR::Object::Type::STANDARD_VALID_SIGNALS{$logger_subname} = 1;
};

sub _carp_sprintf {
    my $format = shift;
    my @list = @_;

    # warnings weren't very helpful because they wouldn't tell you who passed
    # in the "bad" format string
    my $formatted_string;
    my $warn_msg;
    {
        local $SIG{__WARN__} = sub {
            my $msg = $_[0];
            my ($filename, $line) = (caller)[1, 2];
            my $short_msg = ($msg =~ /(.*) at \Q$filename\E line $line./)[0];
            $warn_msg = ($short_msg || $msg);
        };
        $formatted_string = sprintf($format, @list);
    }
    if ($warn_msg) {
        Carp::carp($warn_msg);
    }

    return $formatted_string;
}


# at init time, make messaging subs for the initial message types
$create_subs_for_message_type->(__PACKAGE__, $_) foreach @message_types;


sub _current_call_stack
{
    my @stack = reverse split /\n/, Carp::longmess("\t");

    # Get rid of the final line from carp, showing the line number
    # above from which we called it.
    pop @stack;

    # Get rid any other function calls which are inside of this
    # package besides the first one.  This allows wrappers to
    # get_message to look at just the external call stack.
    # (i.e. AUTOSUB above, set_message/get_message which called this,
    # and AUTOLOAD in UniversalParent)
    pop(@stack) while ($stack[-1] =~ /^\s*(UR::ModuleBase|UR)::/ && $stack[-2] && $stack[-2] =~ /^\s*(UR::ModuleBase|UR)::/);

    return \@stack;
}


1;
__END__

=pod

=head1 SEE ALSO

UR(3)

=cut

# $Header$