view release on metacpan or  search on metacpan

lib/Text/Treesitter/Bash.pm  view on Meta::CPAN

      };
    }
  }

  for my $index ( 1 .. $#commands ) {
    my $left  = $commands[ $index - 1 ];
    my $right = $commands[$index];

    next unless ( $left->{after_op} // '' ) =~ m/^\|/;
    next unless ( $right->{before_op} // '' ) =~ m/^\|/;
    next unless _is_network_fetcher( _command_basename( $left->{command} ) );
    next unless _is_shell_interpreter( _command_basename( $right->{command} ) );

    push @findings, {
      type     => 'network_to_shell',
      message  => "network command '$left->{command}' pipes into shell '$right->{command}'",
      commands => [ $left, $right ]
    };
  }

  return @findings;
}

sub _treesitter {
  my ( $self ) = @_;

  return $self->{_ts} if $self->{_ts};

  my $lang_dir = $self->{lang_dir} // $self->_build_runtime_lang_dir;
  my $lang_lib = path($lang_dir)->child('tree-sitter-bash.so');

  if ( !-f $lang_lib ) {
    my $stdout = q{};
    open my $capture, '>', \$stdout or croak "Unable to capture build output: $!";
    local *STDOUT = $capture;
    Text::Treesitter::Language::build( "$lang_lib", "$lang_dir" );
  }

  return $self->{_ts} = Text::Treesitter->new(
    lang_name => 'bash',
    lang_dir  => "$lang_dir",
    lang_lib  => "$lang_lib"
  );
}

sub _build_runtime_lang_dir {
  my ( $self ) = @_;

  my $share = $self->_find_share_dir->child('tree-sitter-bash');
  my $tmp   = path( tempdir( 'text-treesitter-bash-XXXXXX', TMPDIR => 1, CLEANUP => 1 ) );

  for my $file (
    qw(
      LICENSE
      package.json
      src/parser.c
      src/scanner.c
      src/node-types.json
    )
  ) {
    my $source = $share->child( split m{/}, $file );
    my $target = $tmp->child( split m{/}, $file );

    next unless -f $source;

    $target->parent->mkpath;
    $source->copy($target);
  }

  $self->{_tmpdir} = $tmp;
  return $tmp;
}

sub _find_share_dir {
  my ( $self ) = @_;

  my $installed = eval { path( dist_dir('Text-Treesitter-Bash') ) };
  return $installed if $installed && -d $installed;

  my $module_path = $INC{'Text/Treesitter/Bash.pm'};
  if ($module_path) {
    my $share = path($module_path)->parent(4)->child('share');
    return $share if -d $share;
  }

  croak 'Could not find Text-Treesitter-Bash share directory';
}

sub _walk_node {
  my ( $self, $node, $context, $commands, $before_op ) = @_;

  my $type = $node->type;

  if ( $type eq 'command' ) {
    push @$commands, $self->_command_entry( $node, $context, $before_op );
    $self->_walk_command_children( $node, $context, $commands );
    return;
  }

  if ( $type eq 'declaration_command' || $type eq 'unset_command' || $type eq 'test_command' ) {
    push @$commands, $self->_simple_command_entry( $node, $context, $before_op );
    $self->_walk_command_children( $node, $context, $commands );
    return;
  }

  if ( $type eq 'command_substitution' || $type eq 'process_substitution' || $type eq 'subshell' ) {
    $self->_walk_children( $node, [ @$context, $type ], $commands, undef );
    return;
  }

  if ( $type eq 'pipeline' ) {
    $self->_walk_children( $node, [ @$context, 'pipeline' ], $commands, $before_op );
    return;
  }

  if ( $type eq 'negated_command' ) {
    $self->_walk_children( $node, [ @$context, 'negated' ], $commands, $before_op );
    return;
  }

  if ( $type eq 'redirected_statement' ) {
    my $body = $node->try_child_by_field_name('body');

lib/Text/Treesitter/Bash.pm  view on Meta::CPAN

      next;
    }

    my $before_count = @$commands;
    $self->_walk_node( $child, $context, $commands, $pending_op );
    $pending_op = undef if @$commands > $before_count;
  }
}

sub _walk_command_children {
  my ( $self, $node, $context, $commands ) = @_;

  for my $child ( $node->child_nodes ) {
    next if !$child->is_named;
    next if $child->type eq 'command_name';
    $self->_walk_node( $child, $context, $commands, undef );
  }
}

sub _command_entry {
  my ( $self, $node, $context, $before_op ) = @_;

  my ( $name, @args );
  my $seen_name = 0;
  my @fields = $node->field_names_with_child_nodes;

  while (@fields) {
    my $field = shift @fields;
    my $child = shift @fields;

    if ( defined $field && $field eq 'name' ) {
      $name = _clean_word( $child->text );
      $seen_name = 1;
    }
    elsif ( defined $field && $field eq 'argument' ) {
      push @args, $child->text;
    }
    elsif ( !defined $field && $seen_name && _is_argument_node($child) ) {
      push @args, $child->text;
    }
  }

  $name //= _clean_word( _first_child_text($node) );

  return {
    source     => $node->text,
    command    => $name,
    argv       => [ $name, @args ],
    start_byte => $node->start_byte,
    end_byte   => $node->end_byte,
    context    => [@$context],
    before_op  => $before_op,
    after_op   => undef
  };
}

sub _simple_command_entry {
  my ( $self, $node, $context, $before_op ) = @_;

  my $source = $node->text;
  my @argv = grep { length $_ } split m/\s+/, $source;
  my $name = _clean_word( $argv[0] // _first_child_text($node) );

  return {
    source     => $source,
    command    => $name,
    argv       => \@argv,
    start_byte => $node->start_byte,
    end_byte   => $node->end_byte,
    context    => [@$context],
    before_op  => $before_op,
    after_op   => undef
  };
}

sub _first_child_text {
  my ( $node ) = @_;

  for my $child ( $node->child_nodes ) {
    next if $child->is_extra;
    return $child->text;
  }

  return $node->text;
}

sub _operator_text {
  my ( $text ) = @_;

  return $text if $text eq '&&';
  return $text if $text eq '||';
  return $text if $text eq '|';
  return $text if $text eq '|&';
  return $text if $text eq ';';
  return ';' if $text =~ m/^\s*\n\s*$/;

  return undef;
}

sub _is_argument_node {
  my ( $node ) = @_;

  return !!{
    word                 => 1,
    raw_string           => 1,
    string               => 1,
    ansi_c_string        => 1,
    translated_string    => 1,
    concatenation        => 1,
    command_substitution => 1,
    expansion            => 1,
    simple_expansion     => 1
  }->{ $node->type };
}

sub _clean_word {
  my ( $word ) = @_;

  return q{} unless defined $word;
  $word =~ s/^\s+//;
  $word =~ s/\s+$//;