diff --git a/src/services/tree-sitter/__tests__/fixtures/sample-perl.ts b/src/services/tree-sitter/__tests__/fixtures/sample-perl.ts new file mode 100644 index 0000000000..fe8b5e8340 --- /dev/null +++ b/src/services/tree-sitter/__tests__/fixtures/sample-perl.ts @@ -0,0 +1,271 @@ +export const samplePerlContent = ` +#!/usr/bin/perl +# Comprehensive Perl sample demonstrating various language constructs + +use strict; +use warnings; +use feature qw(say state signatures); +use utf8; + +# Package declaration with version +package MyApp::Utils v1.2.3; + +# Import statements +use List::Util qw(sum max min); +use Data::Dumper; +use Moose; +use Try::Tiny; + +# Constant declarations +use constant { + MAX_RETRIES => 3, + TIMEOUT => 30, + DEBUG_MODE => 1, +}; + +# Traditional subroutine +sub calculate_total { + my ($items, $tax_rate) = @_; + my $subtotal = sum(@$items); + my $tax = $subtotal * $tax_rate; + return $subtotal + $tax; +} + +# Subroutine with prototype +sub add_numbers ($$) { + my ($x, $y) = @_; + return $x + $y; +} + +# Subroutine with signatures (Perl 5.20+) +sub modern_function ($name, $age = 18, @hobbies) { + say "Name: $name"; + say "Age: $age"; + say "Hobbies: " . join(", ", @hobbies); + return { + name => $name, + age => $age, + hobbies => \\@hobbies + }; +} + +# Anonymous subroutine +my $validator = sub { + my ($input) = @_; + return $input =~ /^[a-zA-Z0-9]+$/; +}; + +# Method in OO Perl +sub new { + my ($class, %args) = @_; + my $self = { + name => $args{name} // 'Unknown', + age => $args{age} // 0, + }; + bless $self, $class; + return $self; +} + +# Moose attribute +has 'username' => ( + is => 'rw', + isa => 'Str', + required => 1, + trigger => sub { + my ($self, $new, $old) = @_; + $self->log_change($old, $new); + } +); + +# Method modifier +before 'save' => sub { + my $self = shift; + $self->validate_data(); + $self->update_timestamp(); +}; + +# State variable (persistent lexical) +sub counter { + state $count = 0; + return ++$count; +} + +# BEGIN block +BEGIN { + print "Initializing module...\\n"; + $ENV{APP_MODE} = 'development'; +} + +# END block +END { + print "Cleanup operations...\\n"; + close_all_handles(); +} + +# Regular expression patterns +my $email_regex = qr/^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\\.[a-zA-Z]{2,}$/; +my $phone_regex = qr/^\\+?[1-9]\\d{1,14}$/; + +# Pattern matching +sub parse_log_entry { + my ($line) = @_; + if ($line =~ /^(\\d{4}-\\d{2}-\\d{2}) (\\d{2}:\\d{2}:\\d{2}) \\[(.+?)\\] (.+)$/) { + return { + date => $1, + time => $2, + level => $3, + message => $4, + }; + } + return undef; +} + +# Substitution +sub sanitize_input { + my ($text) = @_; + $text =~ s/<[^>]+>//g; # Remove HTML tags + $text =~ s/^\\s+|\\s+$//g; # Trim whitespace + $text =~ tr/A-Z/a-z/; # Convert to lowercase + return $text; +} + +# Here document +my $config = <<'END_CONFIG'; +[database] +host = localhost +port = 5432 +name = myapp_db + +[cache] +driver = redis +ttl = 3600 +END_CONFIG + +# Format declaration +format REPORT = +@<<<<<<<<<<< @||||||||| @>>>>>>>>> +$name, $status, $score +. + +# Complex data structures +my %user_permissions = ( + admin => { + read => 1, + write => 1, + delete => 1, + }, + user => { + read => 1, + write => 0, + delete => 0, + }, +); + +# Typeglob manipulation +*alias_function = \\&original_function; + +# Exception handling with eval +eval { + dangerous_operation(); + another_risky_call(); +}; +if ($@) { + warn "Error occurred: $@"; + handle_error($@); +} + +# Try::Tiny exception handling +try { + $result = risky_calculation(); +} catch { + warn "Caught error: $_"; + $result = get_default_value(); +} finally { + cleanup_resources(); +}; + +# Given/when (smart matching) +given ($user_type) { + when ('admin') { + grant_full_access(); + } + when ('moderator') { + grant_moderate_access(); + } + when ('user') { + grant_basic_access(); + } + default { + deny_access(); + } +} + +# Package with namespace +package MyApp::Model::User { + use Moose; + use namespace::autoclean; + + has 'id' => ( + is => 'ro', + isa => 'Int', + ); + + has 'email' => ( + is => 'rw', + isa => 'Str', + required => 1, + ); + + sub authenticate { + my ($self, $password) = @_; + return $self->check_password($password); + } + + __PACKAGE__->meta->make_immutable; +} + +# Role definition +package MyApp::Role::Timestamped { + use Moose::Role; + + has 'created_at' => ( + is => 'ro', + isa => 'DateTime', + default => sub { DateTime->now }, + ); + + has 'updated_at' => ( + is => 'rw', + isa => 'DateTime', + ); + + before 'save' => sub { + my $self = shift; + $self->updated_at(DateTime->now); + }; +} + +# Class using role +package MyApp::Model::Post { + use Moose; + with 'MyApp::Role::Timestamped'; + + has 'title' => ( + is => 'rw', + isa => 'Str', + required => 1, + ); + + has 'content' => ( + is => 'rw', + isa => 'Str', + ); +} + +1; # End of module +` + +export default { + path: "test.pl", + content: samplePerlContent, +} diff --git a/src/services/tree-sitter/__tests__/parseSourceCodeDefinitions.perl.spec.ts b/src/services/tree-sitter/__tests__/parseSourceCodeDefinitions.perl.spec.ts new file mode 100644 index 0000000000..93b4754fbc --- /dev/null +++ b/src/services/tree-sitter/__tests__/parseSourceCodeDefinitions.perl.spec.ts @@ -0,0 +1,108 @@ +// npx vitest services/tree-sitter/__tests__/parseSourceCodeDefinitions.perl.spec.ts + +import { testParseSourceCodeDefinitions, debugLog } from "./helpers" +import { samplePerlContent } from "./fixtures/sample-perl" +import { perlQuery } from "../queries" + +// Perl test options +const perlOptions = { + language: "perl", + wasmFile: "tree-sitter-perl.wasm", + queryString: perlQuery, + extKey: "pl", +} + +describe("parseSourceCodeDefinitionsForFile with Perl", () => { + let parseResult: string | undefined + + beforeAll(async () => { + // Cache parse result for all tests + parseResult = await testParseSourceCodeDefinitions("test.pl", samplePerlContent, perlOptions) + debugLog("Perl Parse Result:", parseResult) + }) + + it("should parse subroutine definitions", () => { + expect(parseResult).toMatch(/\d+--\d+ \| sub calculate_total \{/) + expect(parseResult).toMatch(/\d+--\d+ \| sub add_numbers \(\$\$\) \{/) + expect(parseResult).toMatch(/\d+--\d+ \| sub modern_function \(\$name, \$age = 18, @hobbies\) \{/) + expect(parseResult).toMatch(/\d+--\d+ \| my \$validator = sub \{/) + debugLog("Subroutine definitions found:", parseResult) + }) + + it("should parse package and module declarations", () => { + expect(parseResult).toMatch(/\d+--\d+ \| package MyApp::Utils v1\.2\.3;/) + expect(parseResult).toMatch(/\d+--\d+ \| package MyApp::Model::User \{/) + expect(parseResult).toMatch(/\d+--\d+ \| package MyApp::Model::Post \{/) + debugLog("Package declarations found:", parseResult) + }) + + it("should parse use and require statements", () => { + expect(parseResult).toMatch(/\d+--\d+ \| use strict;/) + expect(parseResult).toMatch(/\d+--\d+ \| use warnings;/) + expect(parseResult).toMatch(/\d+--\d+ \| use List::Util qw\(sum max min\);/) + expect(parseResult).toMatch(/\d+--\d+ \| use Moose;/) + debugLog("Import statements found:", parseResult) + }) + + it("should parse OO constructs and Moose attributes", () => { + expect(parseResult).toMatch(/\d+--\d+ \| sub new \{/) + expect(parseResult).toMatch(/\d+--\d+ \| has 'username' => \(/) + expect(parseResult).toMatch(/\d+--\d+ \| has 'email' => \(/) + expect(parseResult).toMatch(/\d+--\d+ \| before 'save' => sub \{/) + debugLog("OO constructs found:", parseResult) + }) + + it("should parse role definitions", () => { + expect(parseResult).toMatch(/\d+--\d+ \| package MyApp::Role::Timestamped \{/) + expect(parseResult).toMatch(/\d+--\d+ \| with 'MyApp::Role::Timestamped';/) + debugLog("Role definitions found:", parseResult) + }) + + it("should parse special blocks", () => { + expect(parseResult).toMatch(/\d+--\d+ \| BEGIN \{/) + expect(parseResult).toMatch(/\d+--\d+ \| END \{/) + debugLog("Special blocks found:", parseResult) + }) + + it("should parse variable declarations", () => { + expect(parseResult).toMatch(/\d+--\d+ \| my \$email_regex = qr/) + expect(parseResult).toMatch(/\d+--\d+ \| my \$config = <<'END_CONFIG';/) + expect(parseResult).toMatch(/\d+--\d+ \| state \$count = 0;/) + expect(parseResult).toMatch(/\d+--\d+ \| my %user_permissions = \(/) + debugLog("Variable declarations found:", parseResult) + }) + + it("should parse constants", () => { + expect(parseResult).toMatch(/\d+--\d+ \| use constant \{/) + expect(parseResult).toMatch(/MAX_RETRIES => 3/) + expect(parseResult).toMatch(/TIMEOUT\s+=> 30/) + debugLog("Constants found:", parseResult) + }) + + it("should parse regex patterns and operations", () => { + expect(parseResult).toMatch(/\d+--\d+ \| if \(\$line =~ /) + expect(parseResult).toMatch(/\d+--\d+ \| \$text =~ s\/<\[\^>\]\+>\/\/g;/) + expect(parseResult).toMatch(/\d+--\d+ \| \$text =~ tr\/A-Z\/a-z\/;/) + debugLog("Regex patterns found:", parseResult) + }) + + it("should parse exception handling", () => { + expect(parseResult).toMatch(/\d+--\d+ \| eval \{/) + expect(parseResult).toMatch(/\d+--\d+ \| try \{/) + expect(parseResult).toMatch(/\d+--\d+ \| } catch \{/) + expect(parseResult).toMatch(/\d+--\d+ \| } finally \{/) + debugLog("Exception handling found:", parseResult) + }) + + it("should parse given/when statements", () => { + expect(parseResult).toMatch(/\d+--\d+ \| given \(\$user_type\) \{/) + expect(parseResult).toMatch(/\d+--\d+ \| when \('admin'\) \{/) + expect(parseResult).toMatch(/\d+--\d+ \| default \{/) + debugLog("Given/when statements found:", parseResult) + }) + + it("should parse format declarations", () => { + expect(parseResult).toMatch(/\d+--\d+ \| format REPORT =/) + debugLog("Format declarations found:", parseResult) + }) +}) diff --git a/src/services/tree-sitter/queries/perl.ts b/src/services/tree-sitter/queries/perl.ts index d77327369c..706c29d05f 100644 --- a/src/services/tree-sitter/queries/perl.ts +++ b/src/services/tree-sitter/queries/perl.ts @@ -1,40 +1,70 @@ /* -Perl Tree-sitter Query Patterns - Based on actual node-types.json structure +Perl Tree-sitter Query Patterns +Enhanced version with improved documentation and structure */ export default ` -; Subroutine declarations (main Perl construct) +; ============================================================================ +; Core Subroutine/Function Definitions +; ============================================================================ + +; Traditional subroutine declarations - the main Perl construct for functions (subroutine_declaration_statement - name: (bareword) @name) @definition.function + name: (bareword) @name.definition.function) @definition.function -; Package statements +; ============================================================================ +; Package/Module/Class Structure +; ============================================================================ + +; Package statements - fundamental Perl organizational unit +; Captures both traditional packages and modern namespaces (package_statement - name: (package) @name) @definition.package + name: (package) @name.definition.package) @definition.package -; Use statements (imports) +; Use statements - imports, pragmas, and module loading +; Examples: use strict; use warnings; use List::Util qw(sum); (use_statement - module: (package) @name) @definition.import + module: (package) @name.definition.import) @definition.import -; Method declarations (modern Perl) +; ============================================================================ +; Modern Perl OO Constructs +; ============================================================================ + +; Method declarations (modern Perl with method keyword) +; Used in frameworks like Moose, Moo, or with Function::Parameters (method_declaration_statement - name: (bareword) @name) @definition.method + name: (bareword) @name.definition.method) @definition.method -; Class statements (modern Perl) +; Class statements (modern Perl OO with class keyword) +; Available in Perl 5.38+ or with Object::Pad, Corinna (class_statement - name: (package) @name) @definition.class + name: (package) @name.definition.class) @definition.class -; Role statements (modern Perl) +; Role statements (Moose/Moo roles for composition) +; Used for role-based composition in modern Perl OO (role_statement - name: (package) @name) @definition.role + name: (package) @name.definition.role) @definition.role -; Variable declarations - capture any variable declaration +; ============================================================================ +; Variable Declarations and Assignments +; ============================================================================ + +; Variable declarations - captures my, our, local, state declarations +; This is a catch-all for all variable declaration types (variable_declaration) @definition.variable -; Assignment expressions for capturing variable assignments +; Assignment expressions - tracks variable assignments and initializations +; Captures both simple and complex assignments (assignment_expression) @definition.assignment -; Function calls for reference tracking +; ============================================================================ +; Function and Method Calls (for reference tracking) +; ============================================================================ + +; Function calls - tracks usage of subroutines and built-in functions +; Examples: print(), calculate_total($items), Data::Dumper::Dumper($ref) (function_call_expression) @reference.function -; Method calls for reference tracking +; Method calls - tracks OO method invocations +; Examples: $object->method(), $class->new(), $self->calculate() (method_call_expression) @reference.method `