File Coverage

blib/lib/Lingua/EN/AddressParse/Grammar.pm
Criterion Covered Total %
statement 60 65 92.3
branch 12 16 75.0
condition n/a
subroutine 5 5 100.0
pod n/a
total 77 86 89.5


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Lingua::EN::AddressParse::Grammar - grammar tree for Lingua::EN::AddressParse
4              
5             =head1 SYNOPSIS
6              
7             Internal functions called from AddressParse.pm module
8              
9             =head1 DESCRIPTION
10              
11             Grammar tree of postal address syntax for Lingua::EN::AddressParse module.
12              
13             The grammar defined here is for use with the Parse::RecDescent module.
14             Note that parsing is done depth first, meaning match the shortest string first.
15             To avoid premature matches, when one rule is a sub set of another longer rule,
16             it must appear after the longer rule. See the Parse::RecDescent documentation
17             for more details.
18              
19             =head1 AUTHOR
20              
21             Lingua::EN::AddressParse::Grammar was written by Kim Ryan, kimryan at cpan d-o-t or g
22              
23             =head1 COPYRIGHT AND LICENSE
24              
25             Copyright (c) 2018 Kim Ryan. All rights reserved.
26              
27             This library is free software; you can redistribute it and/or modify
28             it under the same terms as Perl itself.
29              
30             =cut
31             #-------------------------------------------------------------------------------
32              
33             package Lingua::EN::AddressParse::Grammar;
34 1     1   5 use strict;
  1         2  
  1         22  
35 1     1   4 use warnings;
  1         1  
  1         18  
36 1     1   446 use Locale::SubCountry;
  1         74864  
  1         1075  
37              
38             our $VERSION = '1.27';
39              
40             #-------------------------------------------------------------------------------
41             # Rules that define valid orderings of an addresses components
42             # A (?) refers to an optional component, occurring 0 or more times.
43             # Optional items are returned as an array, which for our case will
44             # always consist of one element, when they exist.
45              
46             my $non_usa_suburban_address_rules =
47             q{
48             full_address :
49              
50             # Note: both sub property and property identifiers should be optional. This
51             # will allow for cases such as 'Lot 123 Xyz Street' where Lot is in effect the house number, even though 'Lot' is grouped as a sub_property label
52             # Also, cases such as 'SHOP 12A, CHAPEL RD STH' have no street number so are incomplete, but still may need to be parsed
53              
54             sub_property(?) property_identifier(?) street_untyped suburb subcountry post_code(?) country(?) non_matching(?)
55             {
56             # block of code to define actions upon successful completion of a
57             # 'production' or rule
58              
59             $return =
60             {
61             # Parse::RecDescent lets you return a single scalar, which we use as
62             # an anonymous hash reference
63             sub_property => $item[1][0],
64             property_identifier => $item[2][0],
65             street_name => $item[3],
66             street_type => '',
67             suburb => $item[4],
68             subcountry => $item[5],
69             post_code => $item[6][0],
70             country => $item[7][0],
71             non_matching => $item[8][0],
72             type => 'suburban'
73             }
74             }
75             |
76              
77             sub_property(?) property_identifier(?) street street_type suburb subcountry post_code(?) country(?) non_matching(?)
78             {
79             $return =
80             {
81             sub_property => $item[1][0],
82             property_identifier => $item[2][0],
83             street_name => $item[3],
84             street_type => $item[4],
85             suburb => $item[5],
86             subcountry => $item[6],
87             post_code => $item[7][0],
88             country => $item[8][0],
89             non_matching => $item[9][0],
90             type => 'suburban'
91             }
92             }
93             |
94              
95              
96             };
97             #-------------------------------------------------------------------------------
98              
99             my $usa_suburban_address_rules =
100             q{
101             full_address :
102              
103              
104             property_identifier(?) street_untyped sub_property(?) suburb subcountry post_code(?) country(?) non_matching(?)
105             # (needs higher precedence than streets with types)
106              
107             {
108             $return =
109             {
110             property_identifier => $item[1][0],
111             street_name => $item[2],
112             street_type => '',
113             sub_property => $item[3][0],
114             suburb => $item[4],
115             subcountry => $item[5],
116             post_code => $item[6][0],
117             country => $item[7][0],
118             non_matching => $item[8][0],
119             type => 'suburban'
120             }
121             }
122             |
123              
124             property_identifier(?) street street_type abbrev_direction(?) sub_property(?) suburb subcountry post_code(?) country(?) non_matching(?)
125             {
126             $return =
127             {
128             property_identifier => $item[1][0],
129             street_name => $item[2],
130             street_type => $item[3],
131             street_direction_suffix => $item[4][0],
132             sub_property => $item[5][0],
133             suburb => $item[6],
134             subcountry => $item[7],
135             post_code => $item[8][0],
136             country => $item[9][0],
137             non_matching => $item[10][0],
138             type => 'suburban'
139             }
140             }
141             |
142              
143             };
144              
145             #-------------------------------------------------------------------------------
146             my $rural_address_rule =
147             q{
148             property_name property_identifier street street_type suburb subcountry post_code(?) country(?) non_matching(?)
149             {
150             $return =
151             {
152             property_name => $item[1],
153             property_identifier => $item[2],
154             street_name => $item[3],
155             street_type => $item[4],
156             suburb => $item[5],
157             subcountry => $item[6],
158             post_code => $item[7][0],
159             country => $item[8][0],
160             non_matching => $item[9][0],
161             type => 'rural'
162             }
163             }
164             |
165             property_name street street_type suburb subcountry post_code(?) country(?) non_matching(?)
166             {
167             $return =
168             {
169             property_name => $item[1],
170             street_name => $item[2],
171             street_type => $item[3],
172             suburb => $item[4],
173             subcountry => $item[5],
174             post_code => $item[6][0],
175             country => $item[7][0],
176             non_matching => $item[8][0],
177             type => 'rural'
178             }
179             }
180             |
181             property_name suburb subcountry post_code(?) country(?) non_matching(?)
182             {
183             $return =
184             {
185             property_name => $item[1],
186             suburb => $item[2],
187             subcountry => $item[3],
188             post_code => $item[4][0],
189             country => $item[5][0],
190             non_matching => $item[6][0],
191             type => 'rural'
192             }
193             }
194             |
195             };
196             #-------------------------------------------------------------------------------
197              
198             my $post_box_rule =
199             q{
200             post_box suburb subcountry post_code(?) country(?) non_matching(?)
201             {
202             $return =
203             {
204             post_box => $item[1],
205             suburb => $item[2],
206             subcountry => $item[3],
207             post_code => $item[4][0],
208             country => $item[5][0],
209             non_matching => $item[6][0],
210             type => 'post_box'
211             }
212             }
213             |
214             };
215             #-------------------------------------------------------------------------------
216              
217             my $road_box_rule =
218             q{
219             road_box street street_type suburb subcountry post_code(?) country(?) non_matching(?)
220             {
221             $return =
222             {
223             road_box => $item[1],
224             street_name => $item[2],
225             street_type => $item[3],
226             suburb => $item[4],
227             subcountry => $item[5],
228             post_code => $item[6][0],
229             country => $item[7][0],
230             non_matching => $item[8][0],
231             type => 'road_box'
232             }
233             }
234             |
235             road_box suburb subcountry post_code(?) country(?) non_matching(?)
236             {
237             $return =
238             {
239             road_box => $item[1],
240             suburb => $item[2],
241             subcountry => $item[3],
242             post_code => $item[4][0],
243             country => $item[5][0],
244             non_matching => $item[6][0],
245             type => 'road_box'
246             }
247             }
248             |
249             };
250              
251             #-------------------------------------------------------------------------------
252              
253             my $non_matching_rule =
254             q{
255             non_matching(?)
256             {
257             $return =
258             {
259             non_matching => $item[1][0],
260             type => 'unknown'
261             }
262             }
263             };
264             #------------------------------------------------------------------------------
265             # Individual components that an address can be composed from. Components are
266             # expressed as literals or Perl regular expressions.
267             #------------------------------------------------------------------------------
268              
269             my $sub_property =
270             q{
271              
272             sub_property:
273              
274             /SUITE \w+ /
275             |
276             sub_property_type unit_number
277             {
278             $return = "$item[1]$item[2]"
279             }
280              
281             # Unit 34, Shop 12C
282              
283             sub_property_type:
284             /(
285             APARTMENT | APT |
286             BAY |
287             DEPARTMENT |
288             FACTORY |
289             FLAT |
290             FRONT |
291             FRNT |
292             GATE |
293             KEY |
294             HANGAR | HNGR |
295             KEY |
296             LOBBY |
297             LBBY |
298             LOT |
299             OFFICE |
300             OFC |
301             LOT |
302             NO |
303             PENTHOUSE |
304             PH |
305             PIER |
306             REAR (OF )? |
307             ROOM |
308             RM |
309             SHOP |
310             SHED |
311             SUITE | STE |
312             TRAILER |
313             TRLR |
314             UNIT |
315             VILLA |
316             \# # Note '#' is a common abbreviation for number in USA
317             )\ /x
318              
319             unit_number:
320             /(
321             \d{1,6} |
322             \d{1,4}[A-Z]{0,2} | # such as 23B, 6AW
323             \d{1,2}[A-Z]\d | # such as 4A5
324             [A-Z]\d[A-Z] | # such as A5J
325             [A-Z]{1,2}\d{0,4} | # such as # D512
326             \d{1,3}-\d{1,3} # such as # 200-204
327             )\ /x
328             };
329              
330             #------------------------------------------------------------------------------
331              
332             my $property_identifier =
333             q{
334             property_identifier :
335              
336             /\d{1,4} 1\/2 / | # fractional number such as 22 1/2 (half numbers are valid in US)
337             /\d{1,5}-\d{1,5} / | # 1002-1006
338             /\d{1,5}[A-Z]? / # 10025A
339             };
340             #------------------------------------------------------------------------------
341              
342             my $property_name =
343             q{
344             # Property or station names like "Old Regret" or 'Never Fail'
345             property_name : /\"[A-Z'-]{2,}( [A-Z'-]{2,})?\" / |
346             /\'[A-Z-]{2,}( [A-Z-]{2,})?\' /
347             };
348             #------------------------------------------------------------------------------
349              
350             my $post_box =
351             q{
352              
353             post_box : post_box_type post_box_number
354             {
355             $return = "$item[1]$item[2]"
356             }
357              
358             # NOTE: extended regexps not useful here, too many spaces to delimit
359             post_box_type :
360             /(
361             GPO\ BOX |
362             LPO\ BOX |
363             P\ ?O\ BOX |
364             PO\ BOX |
365             LOCKED\ BAG |
366             PRIVATE\ BAG
367             )\ /x
368              
369             post_box_number : /[A-Z]?\d{1,6}[A-Z]? /
370             };
371             #------------------------------------------------------------------------------
372              
373             my $road_box =
374             q{
375              
376             road_box : road_box_type road_box_number
377             {
378             $return = "$item[1]$item[2]"
379             }
380              
381             road_box_type :
382             /(
383             CMB | # Community Mail Bag
384             CMA | # Community Mail Agent
385             CPA | # Community Postal Agent
386             RMS | # Roadside Mail Service
387             RMB | # Roadside Mail Box
388             RSD # Roadside Side Delivery
389             )\ /x # note space separator needed at end of token
390              
391             road_box_number : /[A-Z]?\d{1,5}[A-Z]? /
392              
393             };
394             #------------------------------------------------------------------------------
395              
396             my $street =
397             q{
398              
399             # Streets with no street type such as Road, Lane etc.
400             street_untyped :
401              
402             major_road |
403             avenue_ordinal |
404             street_name_single_word |
405             street_noun |
406             french_style |
407             /AVENUE OF \w+ \w+ / # The Americas, Two Rivers etc
408            
409             major_road :
410             /([N|E|S|W] )?(COUNTY |STATE |US |FIRE )?(ALT|HIGHWAY|LANE|HWY|ROAD|RD|RTE|ROUTE) \d{1,3}\w? ([N|E|S|W|NORTH|EAST|SOUTH|WEST] )?/
411              
412             # Avenue C, 12 1/2 etc
413             avenue_ordinal :
414             /([N|E|S|W] )?AVENUE ([A-Z]|\d{1,2}( 1\/2)?) /
415            
416             # TO DO: N,E,S,W END suburb. End is valid street type but always with direction
417              
418             street_name_single_word:
419             /([N|E|S|W] )?(ALDERSGATE|BROADWAY|BOARDWALK|BOULEVARD|BOWERY|ESPLANADE|KINGSWAY|QUEENSWAY|GREENWAY|PARKWAY|PONDWAY|RIVERBANK) /
420             ...!street_type
421             {
422             $return = $item[1]
423             }
424            
425             street_noun:
426             /(THE|VIA) / any_word
427             {
428             $return = "$item[1]$item[2]"
429             }
430            
431             french_style:
432             /RUE (DE |DES )?/ any_word
433             {
434             $return = "$item[1]$item[2]"
435             }
436            
437              
438             #----------------------------------------------------------------------------
439              
440             street:
441            
442             street_prefix(?) street_name
443             {
444             if ( $item[1][0] )
445             {
446             $return = "$item[1][0]$item[2]"
447             }
448             else
449             {
450             $return = $item[2];
451             }
452             }
453             |
454             # Like South Parade, West Street, Lower Rd.
455             # Note: we don't included abbreviated direction here
456             # Note: precedence is important here, this form is less common than above
457            
458             full_direction | general_prefix ...street_type
459             {
460             $return = $item[1];
461             }
462            
463              
464             street_prefix : direction | general_prefix
465            
466             general_prefix:
467             /(
468             NEW|
469             OLD|
470             MT|MOUNT|
471             DAME|
472             SIR|
473             UPPER|
474             LOWER|
475             LA|
476             ST
477             )\ /x
478              
479             street_name :
480              
481             /(N |E |S |W |DR )?(MARTIN LUTHER|MARTIN L|ML) KING ([JS]R )?/ |
482             /MALCOLM X /
483             |
484             street_name_ordinal
485             |
486              
487             # WORD STREET_TYPE STREET_TYPE
488             # Queen's Park Road, Grand Ridge Rd, Terrace Park Drive, Lane Cove Road etc
489             any_word
490             /(
491             BEND|
492             BRAE|
493             BURN|
494             CAY|
495             CHASE|
496             CIRCLE|
497             CENTRAL|
498             CLUB|
499             COURT|
500             CREST|
501             CRESCENT|
502             CROSS|
503             CROSSING|
504             COVE|
505             EDGE|
506             GARDEN|
507             GATE|
508             GREEN|
509             GLEN|
510             GROVE|
511             HAVEN|
512             HEATH|
513             HILL|
514             HOLLOW|
515             ISLAND|
516             ISLE|
517             KEY|
518             KNOLL|
519             LANDING|
520             LANE|
521             LOOP|
522             PASS|
523             PARK|
524             PATH|
525             PARKWAY|
526             PLACE|
527             PLAZA|
528             PLEASANT|
529             POINT|
530             POINTE|
531             RUN|
532             RIDGE|
533             SQUARE|
534             TRAIL|
535             VIEW|
536             VILLAGE|
537             VISTA
538             )\ /x
539             ...street_type
540             {
541             $return = "$item[1]$item[2]"
542             }
543             |
544              
545             # STREET_TYPE WORD STREET_TYPE
546             # Glen Alpine Way, La Boheme Ave, Grove Valley Ave, Green Bay Road
547             /(
548             CIRCLE|
549             CLUB|
550             COURT|
551             CRESCENT|
552             CROSS|
553             GATE|
554             GLADE|
555             GLEN|
556             GREENS?|
557             GROVE|
558             FAIRWAY|
559             HOLLOW|
560             HILL|
561             ISLAND|
562             KEY|
563             KNOLL|
564             LA|
565             LANDING|
566             LANE|
567             LT|
568             PARK|
569             PLAZA|
570             POINT|
571             RIDGE|
572             ST|
573             TRAIL|
574             VILLAGE
575             )\ /x
576             street_name_word ...street_type
577             {
578             $return = "$item[1]$item[2]"
579             }
580             |
581             # TO DO: New York State has streets such as 'Dutch Street Road'
582             #any_word /STREET / .../ROAD|RD /
583             #{
584             # $return = "$item[1]$item[2]"
585             #}
586             #|
587              
588             # Allow for street_type that can also occur as a street name, eg Park Lane, Green Street
589             any_word ...street_type
590             {
591             $return = $item[1]
592             }
593             |
594             # Persons name, such as John F Kennedy Boulevard
595             title(?) any_word street_name_letter street_name_word
596             {
597             $return = "$item[1][0]$item[2]$item[3]$item[4]"
598             }
599             |
600             street_name_words
601             |
602             street_name_letter
603              
604              
605             # Tin Can Bay (Road), South Head (Road) etc
606             street_name_words : street_name_word(1..3)
607             {
608             if ( $item[1][0] and $item[1][1] and $item[1][2] )
609             {
610             $return = "$item[1][0]$item[1][1]$item[1][2]"
611             }
612             elsif ( $item[1][0] and $item[1][1] )
613             {
614             $return = "$item[1][0]$item[1][1]"
615             }
616             else
617             {
618             $return = $item[1][0]
619             }
620             }
621              
622             # A valid word that forms part of a street name. Use look ahead to prevent the
623             # second name of a two word street_type being consumed too early. For example,
624             # Street in Green Street
625             # Even two letter streets such as 'By Street' are valid
626              
627             street_name_word: ...!street_type /[A-Z'-]{2,}\s+/
628             {
629             $return = $item[2]
630             }
631              
632              
633             # eg Bay 12th Ave, 42nd Street
634             street_name_ordinal :
635             any_word(?)
636             /(
637             \d{0,2}1ST |
638             \d{0,2}2ND |
639             \d{0,2}3RD |
640             \d{0,2}[4-9]TH |
641             \d{0,2}0TH |
642             \d{0,1}11TH |
643             \d{0,1}12TH |
644             \d{0,1}13TH
645             )\ /x
646             {
647              
648             if ( $item[1][0] and $item[2] )
649             {
650             $return = "$item[1][0]$item[2]"
651             }
652             elsif ($item[2] )
653             {
654             $return = "$item[2]"
655             }
656             }
657              
658             street_name_letter: /[A-Z]\s+/ # eg B (Street)
659              
660             street_type:
661              
662             /(
663             # Place most frequent types first to speed up matching
664             ST|STREET|
665             RD|ROAD|
666             LA|LN|LANE|
667             AVE?|AVENUE|
668             ALY?|ALLEY|
669             ARC|ARCADE|
670             BATTLEMENT|
671             BROADWATER|
672             BAYWAY|
673             BVD|BLVD?|BOULEVARDE?|
674             BND|BEND|
675             BL|BOWL|
676             BR|BRAE|
677             BROW|
678             CASCADES|
679             CAY|
680             CENTRE|
681             CONCOURSE|
682             CIR|CIRCLE|CRCLE|
683             CCT|CRT|CIR|CIRCUIT|
684             CHASE|
685             CL|CLOSE|
686             CROSS|CROSSOVER|CROSSING|
687             CR?T|COURT|
688             CV|COVE|
689             CRES|CRS|CR|CRESCENT|
690             CREST|
691             CROFT|
692             DELL|
693             DEVIATION|
694             DRIFTWAY|
695             DR|DRV|DRIVE|
696             ENCLOSURE|
697             ENTRANCE|
698             ESP|ESPLANADE|
699             EXP|EXPW?Y|EXPRESSWAY|
700             FAIRWAY|
701             FW?Y|FREEWAY|
702             GATE|
703             GLADE|
704             GRANGE|
705             GLN|GLEN|
706             GREENS?|GRN|
707             GR|GROVE|
708             HAVEN|
709             HEATH|
710             HL|HILL|
711             HWA?Y|HIGHWAY|
712             HOLE|
713             HOLLOW|
714             ISLE?|IS| # Note that Island is a valid street type, but can get confused with suburb name, such as: Main St Clare Island. So don't include it
715             KEY|
716             KNOLL|
717             LANTERNS|
718             LANDING|
719             LOOP|
720             MEWS|
721             MINNOW|
722             OVERFLOW|
723             OVERLOOK|
724             OVAL|
725             PASS|
726             PASSAGE|PSGE|PSG|
727             PATH|
728             PDE|PARADE|
729             PK|PARK|
730             PARKWAY|PKWY|
731             PENINSULA|
732             PIERS|
733             PIKE|
734             PL|PLACE|
735             PLZ|PLAZA|
736             PORTICO|
737             PROMENADE|
738             PT|POINTE?|
739             RAMBLE|
740             RDG|RIDGE|
741             RETREAT|
742             RIDE|RDE|
743             RISE|RSE|
744             RUN|
745             RDY|ROADWAY|
746             ROW|
747             SLIP|
748             SQ|SQUARE|
749             TCE|TRCE|TER|TERRACE|
750             TRL|TRAIL|
751             TPKE|TURNPIKE|
752             TURN|
753             THROUGHWAY|
754             WL?K|WALK|
755             WY|WAY|WYNDE|
756             WAYS # such as in 'The Five Ways'
757             )\ /x # note space separator needed at end of token
758             };
759              
760             #------------------------------------------------------------------------------
761             # Suburbs can be up to three words
762             # Examples: Dee Why or St. Johns Park, French's Forest
763              
764             my $suburb =
765             q
766             {
767             suburb_prefix :
768              
769             street_prefix |
770             /CAPE / |
771             /FORT|FT /
772             /LAKE /
773              
774             suburb:
775             any_word /BY THE SEA /
776             {
777             $return = "$item[1]$item[2]"
778             }
779             |
780             /LAND O LAKES /
781             |
782             # such as Washington Valley, Lane Cove West, Little Egg Harbour Township
783             suburb_prefix(?) any_word suburb_word(0..2)
784             {
785             if ( $item[1][0] )
786             {
787             if ($item[3][0] and $item[3][1])
788             {
789             $return = "$item[1][0]$item[2]$item[3][0]$item[3][1]"
790             }
791             elsif ( $item[3][0] )
792             {
793             $return = "$item[1][0]$item[2]$item[3][0]"
794             }
795             else
796             {
797             $return = "$item[1][0]$item[2]"
798             }
799             }
800             else
801             {
802             if ($item[3][0] and $item[3][1])
803             {
804             $return = "$item[2]$item[3][0]$item[3][1]"
805             }
806             elsif ( $item[3][0] )
807             {
808             $return = "$item[2]$item[3][0]"
809             }
810             else
811             {
812             $return = "$item[2]"
813             }
814             }
815             }
816             |
817             # such as Kippa-ring or Brighton-Le-Sands
818             /[A-Z]{2,}-[A-Z]{2,}(-[A-Z]{2,})? /
819              
820             suburb_word: ...!subcountry any_word
821             };
822             #------------------------------------------------------------------------------
823             my $common_terms =
824             q
825             {
826             # For use in first or second word of double or triple word street names or suburbs
827             # such as Moore Park West
828             any_word: /[A-Z'-]{2,}\s+/
829             {
830             $return = $item[1]
831             }
832              
833             direction: full_direction | abbrev_direction
834              
835             full_direction:
836             /(
837             NORTH |
838             NTH|
839             EAST |
840             SOUTH |
841             STH|
842             WEST
843             )\ /x
844              
845             abbrev_direction:
846             /(
847             N |
848             NE |
849             NW |
850             E |
851             S |
852             SE |
853             SW |
854             W
855             )\ /x
856            
857             title:
858             /(
859             REV |
860             DR
861             )\ /x
862             };
863              
864             #------------------------------------------------------------------------------
865              
866             # note that Northern territory codes can be abbreviated to 3 digits
867             # Example 0800, 800, 2099
868             my $australian_post_code = q{ post_code: /\d{4} ?/ | /8\d{2} ?/ };
869              
870             my $new_zealand_post_code = q{ post_code: /\d{4} ?/ };
871              
872             # Thanks to Steve Taylor for supplying format of Canadian post codes
873             # Example is K1B 4L7
874             my $canadian_post_code = q{ post_code: /[A-Z]\d[A-Z] \d[A-Z]\d ?/ };
875              
876             # Thanks to Mike Edwards for supplying US zip code formats
877             my $US_post_code = q{ post_code: /\d{5}(-?\d{4})? ?/};
878              
879             # Thanks to Mark Summerfield for supplying UK post code formats
880             # Example is SW1A 9ET
881              
882             my $UK_post_code =
883             q{
884             post_code: outward_code inward_code
885             {
886             $return = "$item[1]$item[2]"
887             }
888              
889             outward_code :
890             /(EC[1-4]|WC[12]|S?W1)[A-Z] / | # London specials
891             /[BGLMS]\d\d? / | # Single letter
892             /[A-Z]{2}\d\d? / # Double letter
893              
894             inward_code : /\d[ABD-HJLNP-UW-Z]{2} ?/
895             };
896              
897              
898             my $Australia =
899             q{
900             country:
901             /(AUSTRALIA|AUST|AU) ?/
902             };
903              
904             my $Canada =
905             q{
906             country:
907             /CANADA ?/
908             };
909              
910             my $New_Zealand =
911             q{
912             country:
913             /(NEW ZEALAND|NZ) ?/
914             };
915              
916             my $US =
917             q{
918             country:
919             /(UNITED STATES OF AMERICA|UNITED STATES|USA?) ?/
920             };
921              
922             my $UK =
923             q{
924             country:
925             /(GREAT BRITAIN|UNITED KINGDOM|UK|GB) ?/
926             };
927              
928             my $non_matching = q{ non_matching: /.*/ };
929              
930             #-------------------------------------------------------------------------------
931             sub _create
932             {
933 4     4   9 my $address = shift;
934              
935             # User can specify country either as full name or 2 letter
936             # abbreviation, such as Australia or AU
937 4         21 my $country = Locale::SubCountry->new($address->{country});
938              
939 4         117 $address->{country_code} = $country->country_code;
940              
941 4         24 my $grammar = '';
942 4 100       14 if ( $address->{country_code} eq 'US' )
943             {
944 1         4 $grammar .= $usa_suburban_address_rules;
945             }
946             else
947             {
948 3         10 $grammar .= $non_usa_suburban_address_rules;
949             }
950              
951 4         11 $grammar .= $rural_address_rule;
952 4         9 $grammar .= $post_box_rule;
953 4         9 $grammar .= $road_box_rule;
954 4         7 $grammar .= $non_matching_rule;
955 4         10 $grammar .= $sub_property;
956 4         7 $grammar .= $property_identifier;
957 4         8 $grammar .= $property_name;
958 4         7 $grammar .= $post_box;
959 4         7 $grammar .= $road_box;
960 4         40 $grammar .= $street;
961 4         16 $grammar .= $suburb;
962 4         10 $grammar .= $common_terms;
963              
964 4         8 my $subcountry_grammar = " subcountry :\n";
965              
966             # Loop over all sub countries to create a grammar for all subcountry
967             # combinations for this country. The grammar for Australia will look like
968             #
969             # subcountry : /NSW / |
970             # /QLD / |
971             # /NEW SOUTH WALES /
972             # /QUEENSLAND / |
973              
974 4         12 my @all_codes = $country->all_codes;
975 4         506 my $last_code = pop(@all_codes);
976              
977 4         10 foreach my $code (@all_codes)
978             {
979 298         368 $subcountry_grammar .= "\t/$code / | \n";
980             }
981             # No alternation character needed for last code
982 4         11 $subcountry_grammar .= "\t/$last_code /\n";
983              
984 4 50       13 if ( not $address->{abbreviated_subcountry_only} )
985             {
986 4         8 $subcountry_grammar .= "| \n";
987              
988 4         11 my @all_full_names = $country->all_full_names;
989 4         429 my $last_full_name = pop(@all_full_names);
990              
991              
992 4         10 foreach my $full_name (@all_full_names)
993             {
994 298         352 $full_name = uc(_clean_sub_country_name($full_name));
995 298         537 $subcountry_grammar .= "\t/$full_name / |\n";
996             }
997              
998 4         8 $last_full_name = _clean_sub_country_name($last_full_name);
999 4         37 $subcountry_grammar .= "\t/$last_full_name /\n";
1000             }
1001              
1002 4         41 $grammar .= $subcountry_grammar;
1003              
1004 4 100       26 if ( $address->{country_code} eq 'AU' )
    100          
    100          
    50          
    50          
1005             {
1006 1         3 $grammar .= $australian_post_code;
1007 1         1 $grammar .= $Australia;
1008              
1009             }
1010             elsif ( $address->{country_code} eq 'CA' )
1011             {
1012 1         3 $grammar .= $canadian_post_code;
1013 1         3 $grammar .= $Canada;
1014             }
1015              
1016             elsif ( $address->{country_code} eq 'GB' )
1017             {
1018 1         4 $grammar .= $UK_post_code;
1019 1         3 $grammar .= $UK;
1020             }
1021             elsif ( $address->{country_code} eq 'NZ' )
1022             {
1023 0         0 $grammar .= $new_zealand_post_code;
1024 0         0 $grammar .= $New_Zealand;
1025             }
1026             elsif ( $address->{country_code} eq 'US' )
1027             {
1028 1         3 $grammar .= $US_post_code;
1029 1         2 $grammar .= $US;
1030             }
1031             else
1032             {
1033 0         0 die "Invalid country code or name: $address->{country}";
1034             }
1035              
1036 4         6 $grammar .= $non_matching;
1037              
1038 4         89 return($grammar);
1039             }
1040             #-------------------------------------------------------------------------------
1041             # Some sub countries contain descriptive text, such as
1042             # "Swansea [Abertawe GB-ATA]" in UK, Wales , which should be removed
1043              
1044             sub _clean_sub_country_name
1045             {
1046 302     302   394 my ($sub_country_name) = @_;
1047              
1048 302         332 my $cleaned_sub_country_name;
1049 302 50       438 if ( $sub_country_name =~ /\[/ )
1050             {
1051             # detect any portion in square brackets
1052 0         0 $sub_country_name =~ /^(\w.*) \[.*\]$/;
1053 0         0 $cleaned_sub_country_name = $1;
1054             }
1055             else
1056             {
1057 302         329 $cleaned_sub_country_name = $sub_country_name;
1058             }
1059 302         432 return($cleaned_sub_country_name)
1060             }
1061             #-------------------------------------------------------------------------------
1062             1;