view release on metacpan or  search on metacpan

t/99-performance-regression.t  view on Meta::CPAN

# Inheritance test classes
package Test::Performance::ClassInherit {
    use Class;

    sub BUILD {
        my ($self, $args) = @_;
        $self->{base_build} = 1;
    }

    sub base_method { "base" }
}

package Test::Performance::ClassChild {
    use Class;
    extends 'Test::Performance::ClassInherit';

    sub BUILD {
        my ($self, $args) = @_;
        $self->{child_build} = 1;
    }

    sub child_method { "child" }
}

package Test::Performance::ClassMoreInherit {
    use Class::More;

    has base_build => (default => 0);

    sub BUILD {
        my ($self, $args) = @_;
        $self->{base_build} = 1;
    }

    sub base_method { "base" }
}

package Test::Performance::ClassMoreChild {
    use Class::More;
    extends 'Test::Performance::ClassMoreInherit';

    has child_build => (default => 0);

    sub BUILD {
        my ($self, $args) = @_;
        $self->{child_build} = 1;
    }

    sub child_method { "child" }
}

package main;

my $ITERATIONS = 100000;
my $ROLE_ITERATIONS = 50000;

# Store individual timing results
my %timing_results;

sub run_highres_benchmark {
    my ($code, $iterations) = @_;
    $iterations ||= $ITERATIONS;

    # Warm up
    $code->() for 1..1000;

    my $start = time();
    $code->() for 1..$iterations;
    my $end = time();

    return $end - $start;
}

sub run_benchmarks {
    my %results;

    # Basic Object Creation
    diag "\n=== Benchmarking Basic Object Creation ($ITERATIONS iterations) ===";

    $timing_results{class_create} = run_highres_benchmark(sub {
        Test::Performance::Class->new(name => 'test');
    });

    $timing_results{class_more_create} = run_highres_benchmark(sub {
        Test::Performance::ClassMore->new(name => 'test');
    });

    diag sprintf "  Class:      %.4f seconds", $timing_results{class_create};
    diag sprintf "  Class::More: %.4f seconds", $timing_results{class_more_create};

    # Method Access
    diag "\n=== Benchmarking Method Access ($ITERATIONS iterations) ===";
    my $class_obj = Test::Performance::Class->new;
    my $class_more_obj = Test::Performance::ClassMore->new;

    $timing_results{class_access} = run_highres_benchmark(sub {
        $class_obj->custom_method;
    });

    $timing_results{class_more_access} = run_highres_benchmark(sub {
        $class_more_obj->custom_method;
    });

    diag sprintf "  Class:      %.4f seconds", $timing_results{class_access};
    diag sprintf "  Class::More: %.4f seconds", $timing_results{class_more_access};

    # Role Composition Performance - Same Role with different classes
    diag "\n=== Benchmarking Role Composition ($ROLE_ITERATIONS iterations) ===";

    $timing_results{class_with_role} = run_highres_benchmark(sub {
        Test::Performance::ClassWithRole->new(name => 'test');
    }, $ROLE_ITERATIONS);

    $timing_results{class_more_with_role} = run_highres_benchmark(sub {
        Test::Performance::ClassMoreWithRole->new(name => 'test');
    }, $ROLE_ITERATIONS);

    diag sprintf "  Class + Role:      %.4f seconds", $timing_results{class_with_role};
    diag sprintf "  Class::More + Role: %.4f seconds", $timing_results{class_more_with_role};

    # Role Method Access
    diag "\n=== Benchmarking Role Method Access ($ITERATIONS iterations) ===";
    my $class_role_obj = Test::Performance::ClassWithRole->new(name => 'test');
    my $class_more_role_obj = Test::Performance::ClassMoreWithRole->new(name => 'test');

    $timing_results{class_role_method} = run_highres_benchmark(sub {
        $class_role_obj->role_method;
    });

    $timing_results{class_more_role_method} = run_highres_benchmark(sub {
        $class_more_role_obj->role_method;
    });

    diag sprintf "  Class + Role method:      %.4f seconds", $timing_results{class_role_method};
    diag sprintf "  Class::More + Role method: %.4f seconds", $timing_results{class_more_role_method};

    # Multiple Role Composition
    diag "\n=== Benchmarking Multiple Role Composition (".($ROLE_ITERATIONS/2)." iterations) ===";

    $timing_results{class_multi_role} = run_highres_benchmark(sub {
        Test::Performance::ClassWithMultipleRoles->new;
    }, $ROLE_ITERATIONS/2);

    $timing_results{class_more_multi_role} = run_highres_benchmark(sub {
        Test::Performance::ClassMoreWithMultipleRoles->new;
    }, $ROLE_ITERATIONS/2);

    diag sprintf "  Class + 3 Roles:      %.4f seconds", $timing_results{class_multi_role};
    diag sprintf "  Class::More + 3 Roles: %.4f seconds", $timing_results{class_more_multi_role};

    # Inheritance Performance
    diag "\n=== Benchmarking Inheritance ($ITERATIONS iterations) ===";

    $timing_results{class_inherit} = run_highres_benchmark(sub {
        Test::Performance::ClassChild->new(name => 'test');
    });

    $timing_results{class_more_inherit} = run_highres_benchmark(sub {
        Test::Performance::ClassMoreChild->new(name => 'test');
    });

    diag sprintf "  Class inheritance:      %.4f seconds", $timing_results{class_inherit};
    diag sprintf "  Class::More inheritance: %.4f seconds", $timing_results{class_more_inherit};

    # Calculate combined metrics for regression detection
    $results{basic_creation_time} = $timing_results{class_create};
    $results{method_access_time} = $timing_results{class_access};
    $results{class_with_role_time} = $timing_results{class_with_role};
    $results{class_role_method_time} = $timing_results{class_role_method};
    $results{class_multi_role_time} = $timing_results{class_multi_role};
    $results{inheritance_time} = $timing_results{class_inherit};

    return \%results;
}

sub calculate_performance_ratio {
    my ($class_time, $class_more_time) = @_;
    return 0 if $class_more_time <= 0;
    return $class_time / $class_more_time;
}

sub format_performance_comparison {
    my ($ratio, $operation) = @_;

    if ($ratio > 1) {
        return sprintf "  Class is %.1fx slower than Class::More for $operation", $ratio;
    } elsif ($ratio < 1 && $ratio > 0) {
        return sprintf "  Class is %.1fx faster than Class::More for $operation", 1/$ratio;
    } else {
        return "  Cannot compare performance for $operation (invalid ratio: $ratio)";
    }
}

sub save_performance_baseline {
    my ($results, $file) = @_;

    open my $fh, '>', $file or die "Cannot write baseline: $!";
    print $fh "# Performance baseline data - DO NOT EDIT MANUALLY\n";
    print $fh "# Generated on: " . scalar(localtime) . "\n";
    print $fh "# Iterations: $ITERATIONS\n";
    print $fh "# Role Iterations: $ROLE_ITERATIONS\n\n";

    while (my ($key, $value) = each %$results) {
        print $fh "$key=$value\n";
    }

    while (my ($key, $value) = each %timing_results) {
        print $fh "individual_$key=$value\n";
    }

    close $fh;
    diag "Performance baseline saved to: $file";