view release on metacpan or  search on metacpan

Messenger.pm  view on Meta::CPAN

sub _initialize {
    my $prev  = shift; # HASH ref
    my $opts = shift; # HASH ref
    # inherit from previous opts
    foreach my $key (keys %$prev) {
        $opts->{$key} = $prev->{$key} unless exists($opts->{$key});
    }
    # suppress version announcement
    my $quiet = defined($opts->{quiet}) ? $opts->{quiet} : 0;
    shift if ($quiet and @_ and substr($_[0], 0, 31) eq 'Using Devel::Messenger version ');
    # output function to use
    my $output = '_' . ($opts->{output} || 'none');
    # filename or filehandle
    my $file = '';
    if (defined($opts->{output}) and ref($opts->{output})) {
        $output = '_handle';
        $file = $opts->{output};
    } elsif (!defined(&{"Devel::Messenger::$output"})) {
        $output = '_file';
        $file = $opts->{output};
    }
    # level of debugging (0 for unlimited)
    my $level = (defined($opts->{level}) and ($opts->{level} =~ m/^\d$/)) ? $opts->{level} : 1;
    # prefix function for each line
    my $prefix  = '';
    my $pkgname = $opts->{pkgname} || 0;
    my $linenum = $opts->{linenumber} || 0;
    if ($pkgname) {
        if ($linenum) {
            $prefix = '_prefix';
        } else {
            $prefix = '_prefix_name';
        }
    } elsif ($linenum) {
        $prefix = '_prefix_line';
    }
    # text to wrap around each note
    my ($begin, $end) = _wrapper($opts->{wrap} || '');
    # globalize new subroutine definition?
    my $global = $opts->{global} || 0;
    # set up CODE ref to return
    my $note = sub {
        return _initialize($opts, @_) if (ref($_[0]) eq 'HASH');
        my $debug = (ref($_[0]) eq 'SCALAR' ? ${shift()} : 1);
        return '' if ($output eq '_none');
        return '' if ($debug > $level and $level);
        no strict 'refs';
        &$output($file, splice @trap) if (@trap and $output ne '_trap');
        my $pre = $prefix;
        my @message = grep { defined($_) } @_;
        if (@message and $message[0] eq 'continue') {
            shift @message;
            $pre = '';
        }
        return '' unless @message;
        chomp($message[$#message]) if (substr($end, -1, 1) eq "\n");
        &$output($file, $begin, ($pre ? &$pre(caller) : ''), @message, $end);
    };
    # export subroutine
    if ($global) {
        #my $caller = (caller)[0];
        foreach my $pkg (sort grep { $_ ne 'Devel/Messenger.pm' } 'main', keys %INC) {
            (my $module = $pkg) =~ s/\.pm$//;
            $module =~ s/\//::/g;
            if (defined(&{"$module\::note"})) {
                no strict 'refs';
                #undef &{"$module\::note"} unless ($module eq $caller);
                *{"$module\::note"} = $note;
            }
        }
    }
    # note anything needful
    &$note(@_) if (@_ or (@trap and $output ne '_trap'));
    return $note;
}

# --------------------------- N O T E - M A R K U P -------------------------- #

sub _prefix {
    my ($package, $filename, $line) = @_;
    my ($pkgname) = _prefix_name($package, $filename, $line);
    my ($linenum) = _prefix_line($package, $filename, $line);
    return ($pkgname, ' '.$linenum, ': ');
}

sub _prefix_name {
    my ($package, $filename, $line) = @_;
    return (($package eq 'main' ? $filename : $package), ': ');
}

sub _prefix_line {
    my ($package, $filename, $line) = @_;
    return ("($line)", ': ');
}

sub _wrapper {
    if (ref($_[0]) eq 'ARRAY') {
        return @{shift()};
    } else {
        my $wrapping = shift;
        return ($wrapping, $wrapping); 
    }
}

# ---------------------- O U T P U T - F U N C T I O N S --------------------- #

sub _file {
    my $file = shift;
    if (open NOTE, ">>$file") {
        print NOTE @_;
        close NOTE;
    } else {
        warn "Cannot append to file $file: $!\n";
    }
}

sub _handle {
    my $file = shift;
    print $file @_;
}