view release on metacpan or  search on metacpan

lib/Log/Info/Fork.pm  view on Meta::CPAN

  $args{name} = '*NO NAME*'
    unless exists $args{name} and defined $args{name};

  $self->hash_init (%args);
}

# -------------------------------------
# INSTANCE FINALIZATION
# -------------------------------------

# -------------------------------------
# INSTANCE COMPONENTS
# -------------------------------------

=head1 INSTANCE COMPONENTS

Z<>

=cut

Class::MethodMaker->import
  (
   get_set => [qw/ proc pid name /],
   boolean => [qw/ log_start_end log_args log_exit /],

   # fhs: list of hashrefs; keys:
   #   fh
   #   channel
   #   name
   #   level
   #   pipe
   #   linebuf
   list    => [qw/ fhs  /],
   code    => [qw/ format /],
  );


# -------------------------------------
# INSTANCE HIGHER-LEVEL FUNCTIONS
# -------------------------------------

=head1 INSTANCE HIGHER-LEVEL FUNCTIONS

Z<>

=cut

sub log {
  my $self = shift;
  my ($channel, $level, $source, @message) = @_;

  my $message;
  if ( @message > 1 ) {
    # It's the weirdest thing...
    # sprintf @message here seems to force @message into a scalar context!
    # even making the lhs a list context doesn't help.  Spook!
    $message = sprintf ($message[0], @message[1..$#message]);
  } elsif ( @message == 1 ) {
    $message = $message[0];
  } else {
    $message = sprintf "Empty log invoked at %s:%s", (caller)[0,1];
  }

  $message = $self->format($channel, $level, $source, $message);
  Log ($channel, $level, $message);
}

# -------------------------------------
# INSTANCE HIGHER-LEVEL PROCEDURES
# -------------------------------------

=head1 INSTANCE HIGHER-LEVEL PROCEDURES

Z<>

=cut

=head2 fork

Fork, passing any parameters to the procedure.

=cut

# -------------------------------------

sub fork {
  my $self = shift;

  $_->{pipe} = IO::Pipe->new
    for ($self->fhs);

  if ( $self->log_args ) {
    my $args = (UNIVERSAL::isa($self->proc, 'CODE')          ?
                B::Deparse->new()->coderef2text($self->proc) :
                join ' ', @{$self->proc});
    $args =~ tr/ \t\n/ /s;
    $self->log(CHAN_INFO, LOG_INFO+1, SRC_INFO,
               "Process Args: %s: %s", $self->name, $args);
  }

  if ( $self->log_start_end ) {
    $self->log(CHAN_INFO, LOG_INFO, SRC_INFO,
               "Starting process: %s", $self->name);
  }

  my $pid = fork;
  croak "Couldn't fork: $!\n"
    unless defined $pid;

  unless ( $pid ) {
    # Child
    $_->{pipe}->writer
      for ($self->fhs);

    my $proc = $self->proc;
    if ( UNIVERSAL::isa($proc, 'ARRAY') ) {
      my @proc = @$proc; # Form closure
      $proc = sub { exec @proc }
    }

    for (grep ! ref $_->{fh}, $self->fhs) {