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) 2016 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   4 use strict;
  1         1  
  1         20  
35 1     1   2 use warnings;
  1         2  
  1         17  
36 1     1   479 use Locale::SubCountry;
  1         53467  
  1         1167  
37              
38             our $VERSION = '1.26';
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             # 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             HOLLOW|
713             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
714             KEY|
715             KNOLL|
716             LANTERNS|
717             LANDING|
718             LOOP|
719             MEWS|
720             MINNOW|
721             OVERFLOW|
722             OVERLOOK|
723             OVAL|
724             PASS|
725             PASSAGE|PSGE|PSG|
726             PATH|
727             PDE|PARADE|
728             PK|PARK|
729             PARKWAY|PKWY|
730             PENINSULA|
731             PIERS|
732             PIKE|
733             PL|PLACE|
734             PLZ|PLAZA|
735             PORTICO|
736             PROMENADE|
737             PT|POINTE?|
738             RAMBLE|
739             RDG|RIDGE|
740             RETREAT|
741             RIDE|RDE|
742             RISE|RSE|
743             RUN|
744             RDY|ROADWAY|
745             ROW|
746             SLIP|
747             SQ|SQUARE|
748             TCE|TRCE|TER|TERRACE|
749             TRL|TRAIL|
750             TPKE|TURNPIKE|
751             TURN|
752             THROUGHWAY|
753             WL?K|WALK|
754             WY|WAY|WYNDE|
755             WAYS # such as in 'The Five Ways'
756             )\ /x # note space separator needed at end of token
757             };
758              
759             #------------------------------------------------------------------------------
760             # Suburbs can be up to three words
761             # Examples: Dee Why or St. Johns Park, French's Forest
762              
763             my $suburb =
764             q
765             {
766             suburb_prefix :
767              
768             street_prefix |
769             /CAPE / |
770             /FORT|FT /
771             /LAKE /
772              
773             suburb:
774             any_word /BY THE SEA /
775             {
776             $return = "$item[1]$item[2]"
777             }
778             |
779             /LAND O LAKES /
780             |
781             # such as Washington Valley, Lane Cove West, Little Egg Harbour Township
782             suburb_prefix(?) any_word suburb_word(0..2)
783             {
784             if ( $item[1][0] )
785             {
786             if ($item[3][0] and $item[3][1])
787             {
788             $return = "$item[1][0]$item[2]$item[3][0]$item[3][1]"
789             }
790             elsif ( $item[3][0] )
791             {
792             $return = "$item[1][0]$item[2]$item[3][0]"
793             }
794             else
795             {
796             $return = "$item[1][0]$item[2]"
797             }
798             }
799             else
800             {
801             if ($item[3][0] and $item[3][1])
802             {
803             $return = "$item[2]$item[3][0]$item[3][1]"
804             }
805             elsif ( $item[3][0] )
806             {
807             $return = "$item[2]$item[3][0]"
808             }
809             else
810             {
811             $return = "$item[2]"
812             }
813             }
814             }
815             |
816             # such as Kippa-ring or Brighton-Le-Sands
817             /[A-Z]{2,}-[A-Z]{2,}(-[A-Z]{2,})? /
818              
819             suburb_word: ...!subcountry any_word
820             };
821             #------------------------------------------------------------------------------
822             my $common_terms =
823             q
824             {
825             # For use in first or second word of double or triple word street names or suburbs
826             # such as Moore Park West
827             any_word: /[A-Z'-]{2,}\s+/
828             {
829             $return = $item[1]
830             }
831              
832             direction: full_direction | abbrev_direction
833              
834             full_direction:
835             /(
836             NORTH |
837             NTH|
838             EAST |
839             SOUTH |
840             STH|
841             WEST
842             )\ /x
843              
844             abbrev_direction:
845             /(
846             N |
847             NE |
848             NW |
849             E |
850             S |
851             SE |
852             SW |
853             W
854             )\ /x
855            
856             title:
857             /(
858             REV |
859             DR
860             )\ /x
861             };
862              
863             #------------------------------------------------------------------------------
864              
865             # note that Northern territory codes can be abbreviated to 3 digits
866             # Example 0800, 800, 2099
867             my $australian_post_code = q{ post_code: /\d{4} ?/ | /8\d{2} ?/ };
868              
869             my $new_zealand_post_code = q{ post_code: /\d{4} ?/ };
870              
871             # Thanks to Steve Taylor for supplying format of Canadian post codes
872             # Example is K1B 4L7
873             my $canadian_post_code = q{ post_code: /[A-Z]\d[A-Z] \d[A-Z]\d ?/ };
874              
875             # Thanks to Mike Edwards for supplying US zip code formats
876             my $US_post_code = q{ post_code: /\d{5}(-?\d{4})? ?/};
877              
878             # Thanks to Mark Summerfield for supplying UK post code formats
879             # Example is SW1A 9ET
880              
881             my $UK_post_code =
882             q{
883             post_code: outward_code inward_code
884             {
885             $return = "$item[1]$item[2]"
886             }
887              
888             outward_code :
889             /(EC[1-4]|WC[12]|S?W1)[A-Z] / | # London specials
890             /[BGLMS]\d\d? / | # Single letter
891             /[A-Z]{2}\d\d? / # Double letter
892              
893             inward_code : /\d[ABD-HJLNP-UW-Z]{2} ?/
894             };
895              
896              
897             my $Australia =
898             q{
899             country:
900             /(AUSTRALIA|AUST|AU) ?/
901             };
902              
903             my $Canada =
904             q{
905             country:
906             /CANADA ?/
907             };
908              
909             my $New_Zealand =
910             q{
911             country:
912             /(NEW ZEALAND|NZ) ?/
913             };
914              
915             my $US =
916             q{
917             country:
918             /(UNITED STATES OF AMERICA|UNITED STATES|USA?) ?/
919             };
920              
921             my $UK =
922             q{
923             country:
924             /(GREAT BRITAIN|UNITED KINGDOM|UK|GB) ?/
925             };
926              
927             my $non_matching = q{ non_matching: /.*/ };
928              
929             #-------------------------------------------------------------------------------
930             sub _create
931             {
932 4     4   8 my $address = shift;
933              
934             # User can specify country either as full name or 2 letter
935             # abbreviation, such as Australia or AU
936 4         21 my $country = Locale::SubCountry->new($address->{country});
937              
938 4         85 $address->{country_code} = $country->country_code;
939              
940 4         21 my $grammar = '';
941 4 100       12 if ( $address->{country_code} eq 'US' )
942             {
943 1         3 $grammar .= $usa_suburban_address_rules;
944             }
945             else
946             {
947 3         11 $grammar .= $non_usa_suburban_address_rules;
948             }
949              
950 4         22 $grammar .= $rural_address_rule;
951 4         12 $grammar .= $post_box_rule;
952 4         10 $grammar .= $road_box_rule;
953 4         4 $grammar .= $non_matching_rule;
954 4         10 $grammar .= $sub_property;
955 4         12 $grammar .= $property_identifier;
956 4         7 $grammar .= $property_name;
957 4         5 $grammar .= $post_box;
958 4         8 $grammar .= $road_box;
959 4         20 $grammar .= $street;
960 4         8 $grammar .= $suburb;
961 4         6 $grammar .= $common_terms;
962              
963 4         5 my $subcountry_grammar = " subcountry :\n";
964              
965             # Loop over all sub countries to create a grammar for all subcountry
966             # combinations for this country. The grammar for Australia will look like
967             #
968             # subcountry : /NSW / |
969             # /QLD / |
970             # /NEW SOUTH WALES /
971             # /QUEENSLAND / |
972              
973 4         16 my @all_codes = $country->all_codes;
974 4         962 my $last_code = pop(@all_codes);
975              
976 4         8 foreach my $code (@all_codes)
977             {
978 311         267 $subcountry_grammar .= "\t/$code / | \n";
979             }
980             # No alternation character needed for last code
981 4         10 $subcountry_grammar .= "\t/$last_code /\n";
982              
983 4 50       11 if ( not $address->{abbreviated_subcountry_only} )
984             {
985 4         7 $subcountry_grammar .= "| \n";
986              
987 4         16 my @all_full_names = $country->all_full_names;
988 4         506 my $last_full_name = pop(@all_full_names);
989              
990              
991 4         8 foreach my $full_name (@all_full_names)
992             {
993 311         267 $full_name = uc(_clean_sub_country_name($full_name));
994 311         341 $subcountry_grammar .= "\t/$full_name / |\n";
995             }
996              
997 4         5 $last_full_name = _clean_sub_country_name($last_full_name);
998 4         24 $subcountry_grammar .= "\t/$last_full_name /\n";
999             }
1000              
1001 4         45 $grammar .= $subcountry_grammar;
1002              
1003 4 100       27 if ( $address->{country_code} eq 'AU' )
    100          
    100          
    50          
    50          
1004             {
1005 1         2 $grammar .= $australian_post_code;
1006 1         1 $grammar .= $Australia;
1007              
1008             }
1009             elsif ( $address->{country_code} eq 'CA' )
1010             {
1011 1         3 $grammar .= $canadian_post_code;
1012 1         2 $grammar .= $Canada;
1013             }
1014              
1015             elsif ( $address->{country_code} eq 'GB' )
1016             {
1017 1         4 $grammar .= $UK_post_code;
1018 1         3 $grammar .= $UK;
1019             }
1020             elsif ( $address->{country_code} eq 'NZ' )
1021             {
1022 0         0 $grammar .= $new_zealand_post_code;
1023 0         0 $grammar .= $New_Zealand;
1024             }
1025             elsif ( $address->{country_code} eq 'US' )
1026             {
1027 1         2 $grammar .= $US_post_code;
1028 1         2 $grammar .= $US;
1029             }
1030             else
1031             {
1032 0         0 die "Invalid country code or name: $address->{country}";
1033             }
1034              
1035 4         10 $grammar .= $non_matching;
1036              
1037 4         90 return($grammar);
1038             }
1039             #-------------------------------------------------------------------------------
1040             # Some sub countries contain descriptive text, such as
1041             # "Swansea [Abertawe GB-ATA]" in UK, Wales , which should be removed
1042              
1043             sub _clean_sub_country_name
1044             {
1045 315     315   187 my ($sub_country_name) = @_;
1046              
1047 315         158 my $cleaned_sub_country_name;
1048 315 50       311 if ( $sub_country_name =~ /\[/ )
1049             {
1050             # detect any portion in square brackets
1051 0         0 $sub_country_name =~ /^(\w.*) \[.*\]$/;
1052 0         0 $cleaned_sub_country_name = $1;
1053             }
1054             else
1055             {
1056 315         190 $cleaned_sub_country_name = $sub_country_name;
1057             }
1058 315         300 return($cleaned_sub_country_name)
1059             }
1060             #-------------------------------------------------------------------------------
1061             1;