view release on metacpan or  search on metacpan

lib/Circle/RootObj.pm  view on Meta::CPAN

{
   my $self = shift;
   my ( $name, $cinv ) = @_;

   my $identity = $cinv->connection->identity;

   my $destsession = defined $identity ? $sessions{$identity} : undef or
      return $cinv->responderr( "Cannot find a session for this identity" );

   my $srcsession = $sessions{$name} or
      return $cinv->responderr( "Cannot find a session called '$name'" );

   eval { $destsession->clonefrom( $srcsession ); 1 } or
      return $cinv->responderr( "Cannot clone $name into $identity - $@" );

   return;
}

sub command_eval
   : Command_description("Evaluate a perl expression")
   : Command_arg('expr', eatall => 1)
{
   my $self = shift;
   my ( $expr, $cinv ) = @_;

   my $connection = $cinv->connection;

   my $identity = $connection->identity;
   my $session = defined $identity ? $sessions{$identity} : undef;

   my %pad = (
      ROOT    => $self,
      LOOP    => $self->{loop},
      CONN    => $connection,
      ITEM    => $cinv->invocant,
      SESSION => $session,
   );

   my $result = do {
      local $SIG{__WARN__} = sub {
         my $msg = $_[0];
         $msg =~ s/ at \(eval \d+\) line \d+\.$//;
         chomp $msg;
         $cinv->respondwarn( $msg, level => 2 );
      };

      eval join( "", map { "my \$$_ = \$pad{$_}; " } keys %pad ) . "$expr";
   };

   if( $@ ) {
      my $err = $@; chomp $err;
      $cinv->responderr( "Died: $err" );
   }
   else {
      my @lines;

      my $timedout;
      local $SIG{ALRM} = sub { $timedout = 1; die };
      eval {
         alarm(5);
         @lines = split m/\n/, Data::Dump::dump($result);
         alarm(0);
      };

      if( $timedout ) {
         $cinv->responderr( "Failed - took too long to render results. Try something more specific" );
         return;
      }

      if( @lines > 20 ) {
         @lines = ( @lines[0..18], "...", $lines[-1] );
      }

      if( @lines == 1 ) {
         $cinv->respond( "Result: $lines[0]" );
      }
      else {
         $cinv->respond( "Result:" );
         $cinv->respond( "  $_" ) for @lines;
      }
   }

   return;
}

sub command_rerequire
   : Command_description("Rerequire a perl module")
   : Command_arg('module')
{
   my $self = shift;
   my ( $module, $cinv ) = @_;

   # This might be a module name Foo::Bar or a filename Foo/Bar.pm
   my $filename;

   if( $module =~ m/::/ ) {
      ( $filename = $module ) =~ s{::}{/}g;
      $filename .= ".pm";
   }
   elsif( $module =~ m/^(.*)\.pm$/ ) {
      $filename = $module;
      ( $module = $1 ) =~ s{/}{::}g;
   }
   else {
      return $cinv->responderr( "Unable to recognise if $module is a module name or a file name" );
   }

   if( !exists $INC{$filename} ) {
      return $cinv->responderr( "Module $module in file $filename isn't loaded" );
   }

   {
      local $SIG{__WARN__} = sub {
         my $msg = $_[0];
         $msg =~ s/ at \(eval \d+\) line \d+\.$//;
         chomp $msg;
         $cinv->respondwarn( $msg, level => 2 );
      };

      no warnings 'redefine';

lib/Circle/RootObj.pm  view on Meta::CPAN

   : Command_arg('command', eatall => 1)
{
   my $self = shift;
   my ( $seconds, $text, $cinv ) = @_;

   # TODO: A CommandInvocant subclass that somehow prefixes its output so we
   # know it's delayed output from earlier, so as not to confuse
   my $subinv = $cinv->nest( $text );

   my $cmdname = $subinv->peek_token or
      return $cinv->responderr( "No command given" );

   my $loop = $self->{loop};

   my $id = $loop->enqueue_timer(
      delay => $seconds,
      code => sub {
         eval {
            $subinv->invocant->do_command( $subinv );
         };
         if( $@ ) {
            my $err = $@; chomp $err;
            $cinv->responderr( "Delayed command $cmdname failed - $err" );
         }
      },
   );

   # TODO: Store ID, allow list, cancel, etc...

   return;
}

###
# Configuration management
###

sub command_config
   : Command_description("Save configuration or change details about it")
{
   # The body doesn't matter as it never gets run
}

sub command_config_show
   : Command_description("Show the configuration that would be saved")
   : Command_subof('config')
   : Command_default()
{
   my $self = shift;
   my ( $cinv ) = @_;

   # Since we're only showing config, only fetch it for the invocant
   my $obj = $cinv->invocant;

   unless( $obj->can( "get_configuration" ) ) {
      $cinv->respond( "No configuration" );
      return;
   }

   my $config = YAML::Dump( $obj->get_configuration );

   $cinv->respond( $_ ) for split m/\n/, $config;
   return;
}

sub command_config_save
   : Command_description("Save configuration to disk")
   : Command_subof('config')
{
   my $self = shift;
   my ( $cinv ) = @_;

   my $file = CIRCLERC;
   YAML::DumpFile( $file, $self->get_configuration );

   $cinv->respond( "Configuration written to $file" );
   return;
}

sub command_config_reload
   : Command_description("Reload configuration from disk")
   : Command_subof('config')
{
   my $self = shift;
   my ( $cinv ) = @_;

   my $file = CIRCLERC;
   $self->load_configuration( YAML::LoadFile( $file ) );

   $cinv->respond( "Configuration loaded from $file" );
   return;
}

# For Configurable role
after load_configuration => sub {
   my $self = shift;
   my ( $ynode ) = @_;

   if( my $sessions_ynode = $ynode->{sessions} ) {
      foreach my $sessionname ( keys %$sessions_ynode ) {
         my $sessionnode = $sessions_ynode->{$sessionname};
         my $type = $sessionnode->{type};

         my $session = $self->add_session( $sessionname, "Circle::Session::$type" );
         $session->load_configuration( $sessionnode );
      }
   }
};

after store_configuration => sub {
   my $self = shift;
   my ( $ynode ) = @_;

   my $sessions_ynode = $ynode->{sessions} ||= YAML::Node->new({});
   %$sessions_ynode = ();

   foreach my $identity ( keys %sessions ) {
      my $session = $sessions{$identity};

      my $sessionnode = $session->get_configuration;
      $sessions_ynode->{$identity} = $sessionnode;