lib/App/Test/Generator/Sample/Module.pm

Index Next ➡

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package Test::App::Generator::Sample::Module;
    2: 
    3: use strict;
    4: use warnings;
    5: use Carp    qw(croak);
    6: use Readonly;
    7: 
    8: our $VERSION = '0.36';
    9: 
   10: # --------------------------------------------------
   11: # Validation constants — centralised so that changes
   12: # to limits only need to be made in one place
   13: # --------------------------------------------------
   14: Readonly my $MIN_EMAIL_LEN  => 5;
   15: Readonly my $MAX_EMAIL_LEN  => 254;
   16: Readonly my $MIN_BIRTH_YEAR => 1900;
   17: Readonly my $MIN_NAME_LEN   => 1;
   18: Readonly my $MAX_NAME_LEN   => 50;
   19: Readonly my $MIN_SCORE      => 0.0;
   20: Readonly my $MAX_SCORE      => 100.0;
   21: Readonly my $PASS_THRESHOLD => 60.0;
   22: 
   23: =head1 NAME
   24: 
   25: Test::App::Generator::Sample::Module - Example module for schema extraction testing
   26: 
   27: =head1 VERSION
   28: 
   29: Version 0.36
   30: 
   31: =head1 SYNOPSIS
   32: 
   33:     use Test::App::Generator::Sample::Module;
   34: 
   35:     my $obj = Test::App::Generator::Sample::Module->new();
   36:     my $result = $obj->validate_email('user@example.com');
   37: 
   38: =head1 DESCRIPTION
   39: 
   40: A sample module with a variety of well and poorly documented methods,
   41: used to exercise L<App::Test::Generator::SchemaExtractor>. The methods
   42: cover common parameter types, validation patterns, and confidence levels
   43: so that the extractor's heuristics can be tested against known inputs.
   44: 
   45: =head2 new
   46: 
   47: Constructor. Returns a new instance.
   48: 
   49:     my $obj = Test::App::Generator::Sample::Module->new();
   50: 
   51: =head3 Returns
   52: 
   53: A blessed hashref.
   54: 
   55: =head3 API specification
   56: 
   57: =head4 input
   58: 
   59:     { class => { type => SCALAR } }
   60: 
   61: =head4 output
   62: 
   63:     { type => OBJECT, isa => 'Test::App::Generator::Sample::Module' }
   64: 
   65: =cut
   66: 
   67: sub new {
   68: 	my $class = $_[0];
   69: 
   70: 	# Bless an empty hashref into the calling class
   71: 	return bless {}, $class;
   72: }
   73: 
   74: =head2 validate_email
   75: 
   76: Validate an email address against basic structural rules.
   77: 
   78:     my $ok = $obj->validate_email('user@example.com');
   79: 
   80: =head3 Arguments
   81: 
   82: =over 4
   83: 
   84: =item * C<$email>
   85: 
   86: String (C<$MIN_EMAIL_LEN>-C<$MAX_EMAIL_LEN> chars). Required.
   87: 
   88: =back
   89: 
   90: =head3 Returns
   91: 
   92: 1 if the address is valid. Croaks on any validation failure.
   93: 
   94: =head3 API specification
   95: 
   96: =head4 input
   97: 
   98:     {
   99:         self  => { type => OBJECT, isa => 'Test::App::Generator::Sample::Module' },
  100:         email => { type => SCALAR, min => 5, max => 254 },
  101:     }
  102: 
  103: =head4 output
  104: 
  105:     { type => SCALAR, value => 1 }
  106: 
  107: =cut
  108: 
  109: sub validate_email {
  110: 	my ($self, $email) = @_;
  111: 
  112: 	# Presence check before length checks to give a clear error
  113: 	croak 'Email is required' unless defined $email;
  114: 	croak 'Email too short'   unless length($email) >= $MIN_EMAIL_LEN;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

  115: 	croak 'Email too long'    unless length($email) <= $MAX_EMAIL_LEN;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

  116: 
  117: 	# Basic structural check — one @ with non-empty local and domain parts
  118: 	croak 'Invalid email format'
  119: 		unless $email =~ /^[^@]+\@[^@]+\.[^@]+$/;
  120: 
  121: 	return 1;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  122: }
  123: 
  124: =head2 calculate_age
  125: 
  126: Calculate age in years from a birth year.
  127: 
  128:     my $age = $obj->calculate_age(1985);
  129: 
  130: =head3 Arguments
  131: 
  132: =over 4
  133: 
  134: =item * C<$birth_year>
  135: 
  136: Integer (C<$MIN_BIRTH_YEAR> to current year). Required.
  137: 
  138: =back
  139: 
  140: =head3 Returns
  141: 
  142: Age in years as an integer.
  143: 
  144: =head3 API specification
  145: 
  146: =head4 input
  147: 
  148:     {
  149:         self       => { type => OBJECT, isa => 'Test::App::Generator::Sample::Module' },
  150:         birth_year => { type => SCALAR, min => 1900 },
  151:     }
  152: 
  153: =head4 output
  154: 
  155:     { type => SCALAR }
  156: 
  157: =cut
  158: 
  159: sub calculate_age {
  160: 	my ($self, $birth_year) = @_;
  161: 
  162: 	# Get the current year from the system clock rather than using
  163: 	# a hardcoded value that would become stale each year
  164: 	my $current_year = (localtime)[5] + 1900;
  165: 
  166: 	croak 'Birth year required'          unless defined $birth_year;
  167: 	croak 'Birth year must be a number'  unless $birth_year =~ /^\d+$/;
  168: 
  169: 	# Upper bound is the current year — you cannot be born in the future
  170: 	croak 'Birth year out of range'
  171: 		unless $birth_year >= $MIN_BIRTH_YEAR && $birth_year <= $current_year;

					

					Mutants (Total: 6, Killed: 0, Survived: 6)
					

  172: 
  173: 	return $current_year - $birth_year;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  174: }
  175: 
  176: =head2 process_names
  177: 
  178: Process a list of names and return the count of non-empty entries.
  179: 
  180:     my $count = $obj->process_names(['Alice', 'Bob', '']);
  181: 
  182: =head3 Arguments
  183: 
  184: =over 4
  185: 
  186: =item * C<$names>
  187: 
  188: Arrayref of name strings. Required.
  189: 
  190: =back
  191: 
  192: =head3 Returns
  193: 
  194: Count of non-empty name strings as an integer.
  195: 
  196: =head3 API specification
  197: 
  198: =head4 input
  199: 
  200:     {
  201:         self  => { type => OBJECT,   isa => 'Test::App::Generator::Sample::Module' },
  202:         names => { type => ARRAYREF },
  203:     }
  204: 
  205: =head4 output
  206: 
  207:     { type => SCALAR, min => 0 }
  208: 
  209: =cut
  210: 
  211: sub process_names {
●[NOT COVERED] 212 → 219 → 224●[NOT COVERED] 212 → 219 → 0  212: 	my ($self, $names) = @_;
  213: 
  214: 	croak 'Names required'                    unless defined $names;
  215: 	croak 'Names must be an array reference'  unless ref($names) eq 'ARRAY';
  216: 
  217: 	# Count only non-empty name strings — undef and '' are skipped
  218: 	my $count = 0;
  219: 	for my $name (@{$names}) {
  220: 		# Increment only for defined, non-empty entries
  221: 		$count++ if defined($name) && length($name) > 0;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

  222: 	}
  223: 
●[NOT COVERED] 224 → 224 → 0  224: 	return $count;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  225: }
  226: 
  227: =head2 set_config
  228: 
  229: Store a configuration hashref on the object.
  230: 
  231:     $obj->set_config({ timeout => 30, retries => 3 });
  232: 
  233: =head3 Arguments
  234: 
  235: =over 4
  236: 
  237: =item * C<$config>
  238: 
  239: Hashref of configuration options. Required.
  240: 
  241: =back
  242: 
  243: =head3 Returns
  244: 
  245: 1 on success. Croaks if C<$config> is absent or not a hashref.
  246: 
  247: =head3 API specification
  248: 
  249: =head4 input
  250: 
  251:     {
  252:         self   => { type => OBJECT,  isa => 'Test::App::Generator::Sample::Module' },
  253:         config => { type => HASHREF },
  254:     }
  255: 
  256: =head4 output
  257: 
  258:     { type => SCALAR, value => 1 }
  259: 
  260: =cut
  261: 
  262: sub set_config {
  263: 	my ($self, $config) = @_;
  264: 
  265: 	croak 'Config required'                  unless defined $config;
  266: 	croak 'Config must be a hash reference'  unless ref($config) eq 'HASH';
  267: 
  268: 	# Store the config hashref directly — callers own the data
  269: 	$self->{config} = $config;
  270: 
  271: 	return 1;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  272: }
  273: 
  274: =head2 greet
  275: 
  276: Generate a greeting message for a named person.
  277: 
  278:     my $msg = $obj->greet('Alice');
  279:     my $msg = $obj->greet('Alice', 'Good morning');
  280: 
  281: =head3 Arguments
  282: 
  283: =over 4
  284: 
  285: =item * C<$name>
  286: 
  287: String (C<$MIN_NAME_LEN>-C<$MAX_NAME_LEN> chars). Required.
  288: 
  289: =item * C<$greeting>
  290: 
  291: String. Optional — defaults to C<"Hello">.
  292: 
  293: =back
  294: 
  295: =head3 Returns
  296: 
  297: Greeting string of the form C<"$greeting, $name!">.
  298: 
  299: =head3 API specification
  300: 
  301: =head4 input
  302: 
  303:     {
  304:         self     => { type => OBJECT, isa => 'Test::App::Generator::Sample::Module' },
  305:         name     => { type => SCALAR, min => 1, max => 50 },
  306:         greeting => { type => SCALAR, optional => 1 },
  307:     }
  308: 
  309: =head4 output
  310: 
  311:     { type => SCALAR }
  312: 
  313: =cut
  314: 
  315: sub greet {
  316: 	my ($self, $name, $greeting) = @_;
  317: 
  318: 	croak 'Name is required' unless defined $name;
  319: 	croak 'Name too short'   unless length($name) >= $MIN_NAME_LEN;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

  320: 	croak 'Name too long'    unless length($name) <= $MAX_NAME_LEN;

					

					Mutants (Total: 3, Killed: 0, Survived: 3)
					

  321: 
  322: 	# Apply default greeting when caller does not supply one
  323: 	$greeting ||= 'Hello';
  324: 
  325: 	return "$greeting, $name!";

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  326: }
  327: 
  328: =head2 check_flag
  329: 
  330: Return a normalised boolean for a flag value.
  331: 
  332:     my $result = $obj->check_flag(1);   # returns 1
  333:     my $result = $obj->check_flag(0);   # returns 0
  334: 
  335: =head3 Arguments
  336: 
  337: =over 4
  338: 
  339: =item * C<$enabled>
  340: 
  341: Boolean scalar. Required.
  342: 
  343: =back
  344: 
  345: =head3 Returns
  346: 
  347: 1 if C<$enabled> is true, 0 otherwise.
  348: 
  349: =head3 API specification
  350: 
  351: =head4 input
  352: 
  353:     {
  354:         self    => { type => OBJECT, isa => 'Test::App::Generator::Sample::Module' },
  355:         enabled => { type => SCALAR },
  356:     }
  357: 
  358: =head4 output
  359: 
  360:     { type => SCALAR }
  361: 
  362: =cut
  363: 
  364: sub check_flag {
  365: 	my ($self, $enabled) = @_;
  366: 
  367: 	# Normalise any truthy/falsy value to a strict 1 or 0
  368: 	return $enabled ? 1 : 0;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  369: }
  370: 
  371: =head2 validate_score
  372: 
  373: Validate a numeric test score and return a pass/fail string.
  374: 
  375:     my $status = $obj->validate_score(75.5);  # returns 'Pass'
  376:     my $status = $obj->validate_score(45.0);  # returns 'Fail'
  377: 
  378: =head3 Arguments
  379: 
  380: =over 4
  381: 
  382: =item * C<$score>
  383: 
  384: Number (C<$MIN_SCORE>-C<$MAX_SCORE>). Required.
  385: 
  386: =back
  387: 
  388: =head3 Returns
  389: 
  390: The string C<'Pass'> if the score meets or exceeds C<$PASS_THRESHOLD>,
  391: C<'Fail'> otherwise. Croaks on invalid input.
  392: 
  393: =head3 API specification
  394: 
  395: =head4 input
  396: 
  397:     {
  398:         self  => { type => OBJECT, isa => 'Test::App::Generator::Sample::Module' },
  399:         score => { type => SCALAR, min => 0.0, max => 100.0 },
  400:     }
  401: 
  402: =head4 output
  403: 
  404:     { type => SCALAR }
  405: 
  406: =cut
  407: 
  408: sub validate_score {
  409: 	my ($self, $score) = @_;
  410: 
  411: 	croak 'Score is required'    unless defined $score;
  412: 
  413: 	# Accept integers, decimals, and values like '.5' but not '1.2.3'
  414: 	croak 'Score must be numeric'
  415: 		unless $score =~ /^(?:\d+\.?\d*|\.\d+)$/;
  416: 
  417: 	croak 'Score out of range'
  418: 		unless $score >= $MIN_SCORE && $score <= $MAX_SCORE;

					

					Mutants (Total: 6, Killed: 0, Survived: 6)
					

  419: 
  420: 	# Compare against the pass threshold constant
  421: 	return $score >= $PASS_THRESHOLD ? 'Pass' : 'Fail';

					

					Mutants (Total: 5, Killed: 0, Survived: 5)
					

  422: }
  423: 
  424: =head2 mysterious_method
  425: 
  426: A deliberately under-documented method used to test that
  427: L<App::Test::Generator::SchemaExtractor> correctly assigns low
  428: confidence when validation is absent.
  429: 
  430: =cut
  431: 
  432: sub mysterious_method {
  433: 	my ($self, $thing) = @_;
  434: 
  435: 	# Intentionally unvalidated — used to verify that SchemaExtractor
  436: 	# flags low-confidence schemas when no validation logic is present.
  437: 	# Callers passing non-numeric values will trigger a Perl warning;
  438: 	# this is expected behaviour for this test fixture.
  439: 	return $thing * 2;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  440: }
  441: 
  442: =head1 AUTHOR
  443: 
  444: Example Author
  445: 
  446: =head1 LICENSE
  447: 
  448: This is free software.
  449: 
  450: =cut
  451: 
  452: 1;