lib/Genealogy/Occupation.pm

Structural Coverage (Approximate)

TER1 (Statement): 100.00%
TER2 (Branch): 100.00%
TER3 (LCSAJ): 100.0% (62/62)
Approximate LCSAJ segments: 97

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:

        start → end → jump

start – first line of the linear sequence
end – last line before control flow changes
jump – line execution jumps to next

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation

1: package Genealogy::Occupation; 2: 3: # TODO: railway/railroad = le chemin de fer 4: 5: use strict; 6: use warnings; 7: use 5.014; 8: 9: use Carp qw(croak); 10: use I18N::LangTags::Detect; 11: use Lingua::EN::ABC; 12: use Params::Get; 13: use Readonly; 14: use Params::Validate::Strict qw(validate_strict); 15: use Return::Set qw(set_return); 16: 17: our $VERSION = '0.02'; 18: 19: # Schema for new() arguments 20: Readonly my $NEW_SCHEMA => { 21: warn_on_error => { 22: type => 'boolean', 23: optional => 1, 24: default => 0, 25: }, 26: }; 27: 28: # Schema for normalise() arguments. 29: # Note: occupation is extracted and normalised to an arrayref BEFORE 30: # validate_strict is called, because Params::Validate::Strict does not 31: # yet support union types. Only the remaining named arguments (sex) 32: # are validated here. 33: Readonly my $NORMALISE_SCHEMA => { 34: sex => { 35: type => 'string', 36: optional => 1, 37: memberof => ['M', 'F'], 38: }, 39: }; 40: 41: # Occupations to filter out entirely - these are not real occupations 42: # but rather descriptions of status or domestic roles 43: Readonly my %FILTER => map { lc($_) => 1 } qw( 44: unemployed 45: retired 46: ); 47: 48: # Filter patterns - matched case-insensitively against the occupation 49: Readonly my @FILTER_PATTERNS => ( 50: qr/^scho(?:ol|lar)/i, 51: qr/wife$/i, 52: qr/seeking work/i, 53: qr/domestic duties/i, 54: qr/home duties/i, 55: qr/house\s?hold duties/i, 56: qr/^at school$/i, 57: ); 58: 59: # Direct lookup table for exact normalisation matches. 60: # Keyed on lowercase occupation string. 61: Readonly my %DIRECT => ( 62: 'ag lab' => 'Agricultural Labourer', 63: 'ag labourer' => 'Agricultural Labourer', 64: 'ag labourer pauper' => 'Agricultural Labourer', 65: 'agric labourer' => 'Agricultural Labourer', 66: 'ag lab pauper' => 'Agricultural Labourer', 67: 'farm labourer' => 'Agricultural Labourer', 68: 'agricultural farm labourer' => 'Agricultural Labourer', 69: 'ordinary agricultural labourer' => 'Agricultural Labourer', 70: 'work on farm' => 'Agricultural Labourer', 71: 'agricultural lab' => 'Agricultural Labourer', 72: 'agril labourer' => 'Agricultural Labourer', 73: 'labourer ag' => 'Agricultural Labourer', 74: 'labourer (ag)' => 'Agricultural Labourer', 75: 'platelayer railway' => 'Railway Platelayer', 76: 'general servant domestic' => 'Domestic Servant', 77: 'domestic servant' => 'Domestic Servant', 78: 'lorry driver heavy worker' => 'Lorry Driver', 79: 'laundry man' => 'Laundryman', 80: "brewer's labourer" => 'Brewery Labourer', 81: 'labourer builders' => "Builder's Labourer", 82: 'gardener domestic' => 'Gardener and Domestic', 83: 'gardner and domestic servant' => 'Gardener and Domestic', # sic 84: 'under gardener domestic' => 'Domestic Gardener', 85: 'domestic under gardner' => 'Domestic Gardener', # sic 86: 'market gardener' => 'Market Gardener', 87: 'plate glass cutter' => 'Plate Glass Cutter', 88: 'pfc us army' => 'Private First Class', 89: 'labourer gas stoker' => 'Gas Stoker', 90: ); 91: 92: # Pattern that matches "general serv*dom*" variants 93: Readonly my $GENERAL_SERVANT_RE => qr/^general serv.+dom/i; 94: 95: # French translations keyed on lowercase English occupation. 96: # Values are either a plain string or a hashref with M/F keys 97: # for gendered translations. 98: Readonly my %FRENCH => ( 99: 'postman' => { M => 'Facteur', F => 'Factrice' }, 100: 'farmer' => { M => 'Agriculteur', F => 'Agricultrice' }, 101: 'teacher' => 'Professeur', 102: 'nurse' => { M => 'Infirmier', F => 'InfirmiÃ¨re' }, 103: ); 104: 105: # German translations keyed on lowercase English occupation. 106: # Values are either a plain string or a hashref with M/F keys. 107: Readonly my %GERMAN => ( 108: 'teacher' => { M => 'Lehrer', F => 'Lehrerin' }, 109: 'farmer' => { M => 'Bauer', F => 'Bauerin' }, 110: 'bus driver' => { M => 'Busfahrer', F => 'Busfahrerin' }, 111: 'doctor' => 'Arzt', # simplified non-gendered form for fallback 112: ); 113: 114: =head1 NAME 115: 116: Genealogy::Occupation - Normalise and translate genealogical occupation strings 117: 118: =head1 VERSION 119: 120: Version 0.02 121: 122: =head1 SYNOPSIS 123: 124: use Genealogy::Occupation; 125: 126: my $normaliser = Genealogy::Occupation->new(); 127: 128: my @occupations = $normaliser->normalise( 129: occupation => 'Ag Lab', 130: sex => 'M', 131: ); 132: # Returns ('Agricultural Labourer') 133: 134: # Or pass an arrayref 135: my @more = $normaliser->normalise( 136: occupation => ['Ag Lab', 'Ag Lab', 'Retired'], 137: sex => 'M', 138: ); 139: # Returns ('Agricultural Labourer') - deduplicated and filtered 140: 141: =head1 DESCRIPTION 142: 143: Normalises occupation strings found in genealogical records, handling 144: common abbreviations, malformed entries, locale-specific spellings and 145: translations into French and German. 146: 147: Designed to handle poor-quality data from genealogy software imports 148: where occupation strings may be abbreviated, inconsistent or use 149: archaic terminology. 150: 151: Processing steps applied in order: 152: 153: =over 4 154: 155: =item 1. Filter out non-occupations (Scholar, Retired, Domestic Duties etc) 156: 157: =item 2. Normalise abbreviations and malformed entries to canonical forms 158: 159: =item 3. Deduplicate consecutive identical or equivalent entries (compared on pre-translation normalised forms) 160: 161: =item 4. Apply locale-specific spellings via C<Lingua::EN::ABC> 162: 163: =item 5. Translate to French or German if system locale requires it 164: 165: =back 166: 167: =head1 METHODS 168: 169: =head2 new 170: 171: =head3 Purpose 172: 173: Constructs a new normaliser object. 174: 175: =head3 API Specification 176: 177: =head4 Input 178: 179: { 180: warn_on_error => { 181: type => 'boolean', 182: optional => 1, 183: default => 0, 184: }, 185: } 186: 187: =head4 Output 188: 189: { type => 'object', isa => 'Genealogy::Occupation' } 190: 191: =head3 Arguments 192: 193: =over 4 194: 195: =item * C<warn_on_error> - If true, unknown occupations that cannot be 196: translated will emit a warning via C<carp> rather than silently falling 197: back to English. Optional, defaults to 0. 198: 199: =back 200: 201: =head3 Returns 202: 203: A blessed C<Genealogy::Occupation> object. 204: 205: =head3 Side Effects 206: 207: None. 208: 209: =head3 Notes 210: 211: The system locale is detected once at construction time and cached for 212: the lifetime of the object. 213: 214: =head3 Example 215: 216: my $normaliser = Genealogy::Occupation->new({ 217: warn_on_error => 1, 218: }); 219: 220: =cut 221: 222: sub new { 223: my $class = shift; 224: 225: # Accept both hashref and flat list, defaulting to empty hashref 226: # since all constructor arguments are optional 227: my $args = Params::Get::get_params(undef, @_) // {}; 228: 229: # Validate constructor arguments 230: validate_strict({ 231: description => 'Genealogy::Occupation::new', 232: input => $args, 233: schema => $NEW_SCHEMA, 234: }); 235: 236: # Detect and cache the system language at construction time 237: my $language = _get_language(); 238: 239: return bless { 240: warn_on_error => $args->{warn_on_error} // 0, 241: language => $language, 242: }, $class; 243: } 244: 245: =head2 normalise 246: 247: =head3 Purpose 248: 249: Normalises one or more occupation strings, applying filtering, 250: deduplication, abbreviation expansion, locale spelling and 251: translation in order. 252: 253: =head3 API Specification 254: 255: =head4 Input 256: 257: { 258: occupation => { 259: type => ['string', 'arrayref'], 260: }, 261: sex => { 262: type => 'string', 263: optional => 1, 264: memberof => ['M', 'F'], 265: }, 266: } 267: 268: =head4 Output 269: 270: { 271: type => 'arrayref', 272: element_type => 'string', 273: } 274: 275: =head3 Arguments 276: 277: =over 4 278: 279: =item * C<occupation> - A single occupation string or an arrayref of 280: occupation strings. Required. 281: 282: =item * C<sex> - The sex of the person, C<'M'> or C<'F'>. Optional 283: but required for correct gendered translations in French and German. 284: Defaults to C<'M'> if not provided when a gendered translation is 285: needed. 286: 287: =back 288: 289: =head3 Returns 290: 291: An arrayref of normalised occupation strings. May be empty if all 292: occupations were filtered out. 293: 294: =head3 Side Effects 295: 296: If C<warn_on_error> was set at construction and an occupation cannot 297: be translated, emits a warning via C<carp>. 298: 299: =head3 Notes 300: 301: Deduplication operates across the full list of occupations passed in. 302: Processing a single occupation at a time will not deduplicate across 303: multiple calls. 304: 305: Deduplication compares the pre-translation normalised English forms, not 306: the translated output. This means two consecutive identical English 307: occupations correctly collapse to one entry even in French or German 308: locales, where the translated results stored in the output array would 309: otherwise never match the incoming English string. 310: 311: =head3 Example 312: 313: my $result = $normaliser->normalise( 314: occupation => ['Ag Lab', 'Ag Lab', 'Retired'], 315: sex => 'M', 316: ); 317: # Returns ['Agricultural Labourer'] 318: 319: my $result = $normaliser->normalise( 320: occupation => 'Platelayer Railway', 321: ); 322: # Returns ['Railway Platelayer'] 323: 324: =cut 325: 326: sub normalise { ●327 → 360 → 406●327 → 360 → 0 327: my $self = shift; 328: 329: # Accept both hashref and flat list 330: my $args = Params::Get::get_params(undef, @_); 331: 332: # Extract and normalise occupation to an arrayref BEFORE calling 333: # validate_strict. Params::Validate::Strict does not yet support 334: # union types, so passing an arrayref against a 'string' schema 335: # would die. We handle the type check here explicitly instead. 336: my $raw = delete $args->{occupation}; 337: croak 'Genealogy::Occupation::normalise: occupation is required' 338: unless defined $raw; 339: my $occupations = ref($raw) eq 'ARRAY' ? $raw : [ $raw ]; 340: 341: # Validate remaining named arguments (sex) strictly 342: validate_strict({ 343: description => 'Genealogy::Occupation::normalise', 344: input => $args, 345: schema => $NORMALISE_SCHEMA, 346: }); 347: 348: # Default sex to M if not provided, needed for gendered translations 349: my $sex = $args->{sex} // 'M'; 350: 351: my $language = $self->{language} // 'en'; 352: my @result; 353: # Track the last normalised English form for deduplication. We cannot 354: # use $result[-1] for this because @result stores the translated output; 355: # comparing a translated value against a pre-translation English string 356: # means consecutive identical occupations are never deduplicated in 357: # French or German locales. 358: my $last_normalised = ''; 359: 360: foreach my $occupation (@{$occupations}) { 361: # Clean up whitespace and punctuation artifacts 362: $occupation =~ tr/\r\n/ /; 363: $occupation =~ s/\.+$//; 364: $occupation =~ s/[]//g; 365: $occupation =~ s/\s\s+/ /g; 366: $occupation =~ s/\s+$//; 367: $occupation =~ s/\./;/g; 368: 369: # Step 1: filter out non-occupations 370: next if $FILTER{lc($occupation)}; 371: my $filtered = 0; 372: foreach my $pattern (@FILTER_PATTERNS) {