File Coverage

blib/lib/Chemistry/OpenSMILES/Parser.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             ####################################################################
2             #
3             # This file was generated using Parse::Yapp version 1.21.
4             #
5             # Don't edit this file, use source file instead.
6             #
7             # ANY CHANGE MADE HERE WILL BE LOST !
8             #
9             ####################################################################
10             package Chemistry::OpenSMILES::Parser;
11 21     21   11033 use vars qw ( @ISA );
  21         119  
  21         1590  
12 21     21   149 use strict;
  21         60  
  21         719  
13              
14             @ISA= qw ( Parse::Yapp::Driver );
15 21     21   10819 use Parse::Yapp::Driver;
  21         47026  
  21         7197  
16              
17             #line 3 "lib/Chemistry/OpenSMILES/Parser.yp"
18              
19              
20             use warnings;
21             use 5.0100;
22              
23             use Chemistry::OpenSMILES qw(
24             is_aromatic
25             is_chiral
26             %normal_valence
27             toggle_cistrans
28             );
29             use Graph::Undirected;
30             use List::Util qw(any sum);
31              
32             my %bond_order = (
33             '-' => 1,
34             '=' => 2,
35             '#' => 3,
36             '$' => 4,
37             );
38              
39              
40              
41             sub new {
42             my($class)=shift;
43             ref($class)
44             and $class=ref($class);
45              
46             my($self)=$class->SUPER::new( yyversion => '1.21',
47             yystates =>
48             [
49             {#State 0
50             ACTIONS => {
51             'atom' => 1
52             },
53             GOTOS => {
54             'smiles' => 2,
55             'chain' => 3
56             }
57             },
58             {#State 1
59             DEFAULT => -2
60             },
61             {#State 2
62             ACTIONS => {
63             '' => 4
64             }
65             },
66             {#State 3
67             ACTIONS => {
68             "\\" => 14,
69             "(" => 13,
70             "/" => 12,
71             "#" => 16,
72             "." => 11,
73             ":" => 7,
74             "\$" => 6,
75             "=" => 10,
76             'ringbond' => 8,
77             'atom' => 9,
78             "-" => 5
79             },
80             DEFAULT => -1,
81             GOTOS => {
82             'bond' => 15
83             }
84             },
85             {#State 4
86             DEFAULT => 0
87             },
88             {#State 5
89             DEFAULT => -11
90             },
91             {#State 6
92             DEFAULT => -14
93             },
94             {#State 7
95             DEFAULT => -15
96             },
97             {#State 8
98             DEFAULT => -9
99             },
100             {#State 9
101             DEFAULT => -3
102             },
103             {#State 10
104             DEFAULT => -12
105             },
106             {#State 11
107             ACTIONS => {
108             'atom' => 17
109             }
110             },
111             {#State 12
112             DEFAULT => -16
113             },
114             {#State 13
115             ACTIONS => {
116             "-" => 5,
117             "=" => 10,
118             'atom' => 1,
119             ":" => 7,
120             "\$" => 6,
121             "." => 19,
122             "#" => 16,
123             "\\" => 14,
124             "/" => 12
125             },
126             GOTOS => {
127             'chain' => 18,
128             'bond' => 20
129             }
130             },
131             {#State 14
132             DEFAULT => -17
133             },
134             {#State 15
135             ACTIONS => {
136             'atom' => 22,
137             'ringbond' => 21
138             }
139             },
140             {#State 16
141             DEFAULT => -13
142             },
143             {#State 17
144             DEFAULT => -5
145             },
146             {#State 18
147             ACTIONS => {
148             "\\" => 14,
149             "(" => 13,
150             "/" => 12,
151             "#" => 16,
152             "." => 11,
153             ":" => 7,
154             "\$" => 6,
155             "=" => 10,
156             'ringbond' => 8,
157             ")" => 23,
158             'atom' => 9,
159             "-" => 5
160             },
161             GOTOS => {
162             'bond' => 15
163             }
164             },
165             {#State 19
166             ACTIONS => {
167             'atom' => 1
168             },
169             GOTOS => {
170             'chain' => 24
171             }
172             },
173             {#State 20
174             ACTIONS => {
175             'atom' => 1
176             },
177             GOTOS => {
178             'chain' => 25
179             }
180             },
181             {#State 21
182             DEFAULT => -10
183             },
184             {#State 22
185             DEFAULT => -4
186             },
187             {#State 23
188             DEFAULT => -6
189             },
190             {#State 24
191             ACTIONS => {
192             "\$" => 6,
193             ":" => 7,
194             'ringbond' => 8,
195             'atom' => 9,
196             ")" => 26,
197             "=" => 10,
198             "-" => 5,
199             "/" => 12,
200             "(" => 13,
201             "\\" => 14,
202             "#" => 16,
203             "." => 11
204             },
205             GOTOS => {
206             'bond' => 15
207             }
208             },
209             {#State 25
210             ACTIONS => {
211             "-" => 5,
212             ":" => 7,
213             "\$" => 6,
214             "=" => 10,
215             'ringbond' => 8,
216             'atom' => 9,
217             ")" => 27,
218             "." => 11,
219             "\\" => 14,
220             "(" => 13,
221             "/" => 12,
222             "#" => 16
223             },
224             GOTOS => {
225             'bond' => 15
226             }
227             },
228             {#State 26
229             DEFAULT => -8
230             },
231             {#State 27
232             DEFAULT => -7
233             }
234             ],
235             yyrules =>
236             [
237             [#Rule 0
238             '$start', 2, undef
239             ],
240             [#Rule 1
241             'smiles', 1, undef
242             ],
243             [#Rule 2
244             'chain', 1,
245             sub
246             #line 35 "lib/Chemistry/OpenSMILES/Parser.yp"
247             {
248             my $g = Graph::Undirected->new( refvertexed => 1 );
249             $g->add_vertex( $_[1] );
250             push @{$_[0]->{USER}{GRAPHS}}, $g;
251              
252             $_[1]->{graph} = $g;
253             $_[1]->{index} = @{$_[0]->{USER}{GRAPHS}}-1;
254             $_[1]->{first_of_chain} = 1;
255              
256             return { first => $_[1],
257             last => $_[1] };
258             }
259             ],
260             [#Rule 3
261             'chain', 2,
262             sub
263             #line 48 "lib/Chemistry/OpenSMILES/Parser.yp"
264             {
265             $_[2]->{graph} = $_[1]->{last}{graph};
266             $_[2]->{index} = $_[1]->{last}{index};
267              
268             $_[2]->{graph}->add_edge( $_[1]->{last}, $_[2] );
269              
270             if( is_aromatic $_[1]->{last} && is_aromatic $_[2] ) {
271             $_[2]->{graph}->set_edge_attribute( $_[1]->{last},
272             $_[2],
273             'bond',
274             ':' );
275             }
276              
277             delete $_[2]->{first_of_chain};
278              
279             _push_chirality_neighbour( $_[1]->{last}, $_[2] );
280             _push_chirality_neighbour( $_[2], $_[1]->{last} );
281              
282             $_[1]->{last} = $_[2];
283              
284             return $_[1];
285             }
286             ],
287             [#Rule 4
288             'chain', 3,
289             sub
290             #line 71 "lib/Chemistry/OpenSMILES/Parser.yp"
291             {
292             $_[3]->{graph} = $_[1]->{last}{graph};
293             $_[3]->{index} = $_[1]->{last}{index};
294              
295             if( $_[2] ne '-' ) {
296             $_[3]->{graph}->set_edge_attribute( $_[1]->{last},
297             $_[3],
298             'bond',
299             $_[2] );
300             } else {
301             $_[3]->{graph}->add_edge( $_[1]->{last}, $_[3] );
302             }
303              
304             delete $_[3]->{first_of_chain};
305              
306             _push_chirality_neighbour( $_[1]->{last}, $_[3] );
307             _push_chirality_neighbour( $_[3], $_[1]->{last} );
308              
309             $_[1]->{last} = $_[3];
310              
311             return $_[1];
312             }
313             ],
314             [#Rule 5
315             'chain', 3,
316             sub
317             #line 94 "lib/Chemistry/OpenSMILES/Parser.yp"
318             {
319             my $g = Graph::Undirected->new( refvertexed => 1 );
320             $g->add_vertex( $_[3] );
321             push @{$_[0]->{USER}{GRAPHS}}, $g;
322              
323             $_[3]->{graph} = $g;
324             $_[3]->{index} = @{$_[0]->{USER}{GRAPHS}}-1;
325             $_[3]->{first_of_chain} = 1;
326              
327             return { first => $_[3],
328             last => $_[3] };
329             }
330             ],
331             [#Rule 6
332             'chain', 4,
333             sub
334             #line 107 "lib/Chemistry/OpenSMILES/Parser.yp"
335             {
336             if( $_[1]->{last}{index} != $_[3]->{first}{index} ) {
337             $_[0]->_merge_graphs( $_[1]->{last}{index},
338             $_[3]->{first}{index} );
339             }
340              
341             $_[1]->{last}{graph}->add_edge( $_[1]->{last}, $_[3]->{first} );
342              
343             if( is_aromatic $_[1]->{last} && is_aromatic $_[3]->{first} ) {
344             $_[1]->{last}{graph}->set_edge_attribute( $_[1]->{last},
345             $_[3]->{first},
346             'bond',
347             ':' );
348             }
349              
350             delete $_[3]->{first}{first_of_chain};
351              
352             _push_chirality_neighbour( $_[1]->{last}, $_[3]->{first} );
353             _unshift_chirality_neighbour( $_[3]->{first}, $_[1]->{last} );
354              
355             return $_[1];
356             }
357             ],
358             [#Rule 7
359             'chain', 5,
360             sub
361             #line 130 "lib/Chemistry/OpenSMILES/Parser.yp"
362             {
363             if( $_[1]->{last}{index} != $_[4]->{first}{index} ) {
364             $_[0]->_merge_graphs( $_[1]->{last}{index},
365             $_[4]->{first}{index} );
366             }
367              
368             if( $_[3] ne '-' ) {
369             $_[1]->{last}{graph}->set_edge_attribute( $_[1]->{last},
370             $_[4]->{first},
371             'bond',
372             $_[3] );
373             } else {
374             $_[1]->{last}{graph}->add_edge( $_[1]->{last},
375             $_[4]->{first} );
376             }
377              
378             delete $_[4]->{first}{first_of_chain};
379              
380             _push_chirality_neighbour( $_[1]->{last}, $_[4]->{first} );
381             _unshift_chirality_neighbour( $_[4]->{first}, $_[1]->{last} );
382              
383             return $_[1];
384             }
385             ],
386             [#Rule 8
387             'chain', 5, undef
388             ],
389             [#Rule 9
390             'chain', 2,
391             sub
392             #line 160 "lib/Chemistry/OpenSMILES/Parser.yp"
393             {
394             $_[0]->_add_ring_bond( $_[1]->{last}, $_[2] );
395             return $_[1];
396             }
397             ],
398             [#Rule 10
399             'chain', 3,
400             sub
401             #line 165 "lib/Chemistry/OpenSMILES/Parser.yp"
402             {
403             $_[0]->_add_ring_bond( $_[1]->{last}, $_[3], $_[2] );
404             return $_[1];
405             }
406             ],
407             [#Rule 11
408             'bond', 1, undef
409             ],
410             [#Rule 12
411             'bond', 1, undef
412             ],
413             [#Rule 13
414             'bond', 1, undef
415             ],
416             [#Rule 14
417             'bond', 1, undef
418             ],
419             [#Rule 15
420             'bond', 1, undef
421             ],
422             [#Rule 16
423             'bond', 1, undef
424             ],
425             [#Rule 17
426             'bond', 1, undef
427             ]
428             ],
429             @_);
430             bless($self,$class);
431             }
432              
433             #line 173 "lib/Chemistry/OpenSMILES/Parser.yp"
434              
435              
436             # Footer section
437              
438             sub _Error
439             {
440             my( $self ) = @_;
441             close $self->{USER}{FILEIN} if $self->{USER}{FILEIN};
442              
443             if( ${$self->{TOKEN}} eq '' &&
444             grep { defined $_ && !ref $_ && $_ eq '(' }
445             map { $_->[1] } @{$self->{STACK}} ) {
446             die "$0: syntax error: missing closing parenthesis.\n";
447             }
448              
449             if( ${$self->{TOKEN}} eq ')' ) {
450             die "$0: syntax error: unbalanced parentheses.\n";
451             }
452              
453             my $msg = "$0: syntax error at position $self->{USER}{CHARNO}";
454             if( $self->YYData->{INPUT} ) {
455             $self->YYData->{INPUT} =~ s/\n$//;
456             die "$msg: '" . $self->YYData->{INPUT} . "'.\n";
457             } else {
458             die "$msg.\n";
459             }
460             }
461              
462             sub _Lexer
463             {
464             my( $self ) = @_;
465              
466             # If the line is empty and the input is originating from the file,
467             # another line is read.
468             if( !$self->YYData->{INPUT} && $self->{USER}{FILEIN} ) {
469             my $filein = $self->{USER}{FILEIN};
470             $self->YYData->{INPUT} = <$filein>;
471             $self->{USER}{CHARNO} = 0;
472             }
473              
474             if( $self->YYData->{INPUT} =~ s/^(\s+)// ) {
475             $self->{USER}{CHARNO} += length $1;
476             }
477              
478             my $hcount_re = 'H[0-9]?';
479             if( defined $self->{USER}{OPTIONS}{max_hydrogen_count_digits} ) {
480             $hcount_re = sprintf 'H[0-9]{0,%d}',
481             $self->{USER}{OPTIONS}{max_hydrogen_count_digits};
482             }
483              
484             # Bracket atoms
485             if( $self->YYData->{INPUT} =~ s/^\[ (?[0-9]+)?
486             (?[A-Za-z][a-z]?|\*)
487             (?@(
488             (TH|AL)[12] |
489             SP [123] |
490             (TB|OH)[0-9]{1,2} |
491             @?
492             ))?
493             (? $hcount_re)?
494             (?--|\+\+|[-+][0-9]{0,2})?
495             (:(?[0-9]+))? \]//x ) {
496             my $atom = { %+, number => $self->{USER}{ATOMNO} };
497             $self->{USER}{ATOMNO} ++;
498             $self->{USER}{CHARNO} += length $&;
499              
500             if( $atom->{charge} ) {
501             $atom->{charge} =~ s/^([-+])$/${1}1/;
502             $atom->{charge} =~ s/^([-+])\1$/${1}2/;
503             $atom->{charge} = int $atom->{charge};
504             }
505              
506             if( $atom->{hcount} ) {
507             $atom->{hcount} =~ s/^H//;
508             $atom->{hcount} = $atom->{hcount} ? int $atom->{hcount} : 1;
509             } else {
510             $atom->{hcount} = 0;
511             }
512              
513             if( $atom->{isotope} ) {
514             $atom->{isotope} = int $atom->{isotope};
515             }
516              
517             # Atom class is an arbitrary number, 0 by default
518             $atom->{class} = exists $atom->{class} ? int $atom->{class} : 0;
519              
520             return ( 'atom', $atom );
521             }
522              
523             # Bracketless atoms
524             if( $self->YYData->{INPUT} =~ s/^(Br|Cl|[BCINOPSFbcnops*])// ) {
525             my $atom = { symbol => $1,
526             class => 0,
527             number => $self->{USER}{ATOMNO} };
528             $self->{USER}{ATOMNO} ++;
529             $self->{USER}{CHARNO} += length $&;
530             return ( 'atom', $atom );
531             }
532              
533             # Ring bonds
534             if( $self->YYData->{INPUT} =~ s/^%([0-9]{2})// ||
535             $self->YYData->{INPUT} =~ s/^([0-9])// ) {
536             $self->{USER}{CHARNO} += length $&;
537             return ( 'ringbond', int $1 );
538             }
539              
540             my $char = substr( $self->YYData->{INPUT}, 0, 1 );
541             if( $char ne '' ) {
542             $self->YYData->{INPUT} = substr( $self->YYData->{INPUT}, 1 );
543             }
544             $self->{USER}{CHARNO} ++;
545             return( $char, $char );
546             }
547              
548             sub parse
549             {
550             my( $self, $string, $options ) = @_;
551             $options = {} unless $options;
552              
553             $self->YYData->{INPUT} = $string;
554             $self->{USER}{GRAPHS} = [];
555             $self->{USER}{RINGBONDS} = {};
556             $self->{USER}{ATOMNO} = 0;
557             $self->{USER}{CHARNO} = 0;
558             $self->{USER}{OPTIONS} = $options;
559             $self->YYParse( yylex => \&_Lexer,
560             yyerror => \&_Error,
561             yydebug => $options->{debug} );
562              
563             if( scalar keys %{$self->{USER}{RINGBONDS}} ) {
564             die "$0: unclosed ring bond(s) detected: " .
565             join( ', ', sort { $a <=> $b } keys %{$self->{USER}{RINGBONDS}} ) .
566             ".\n";
567             }
568              
569             my @graphs = grep { defined } @{$self->{USER}{GRAPHS}};
570             for my $graph (@graphs) {
571             for my $atom (sort { $a->{number} <=> $b->{number} } $graph->vertices) {
572             delete $atom->{graph};
573             delete $atom->{index};
574             if( !$options->{raw} ) {
575             # Promote implicit hydrogen atoms into explicit ones
576             if( !exists $atom->{hcount} ) {
577             next if !exists $normal_valence{$atom->{symbol}};
578             my $degree = sum map { exists $bond_order{$_} ? $bond_order{$_} : 1 }
579             map { $graph->has_edge_attribute( $atom, $_, 'bond' )
580             ? $graph->get_edge_attribute( $atom, $_, 'bond' )
581             : '-' }
582             $graph->neighbours( $atom );
583             $degree = 0 unless $degree;
584             my( $valence ) = grep { $degree <= $_ }
585             @{$normal_valence{$atom->{symbol}}};
586             next if !defined $valence;
587             $atom->{hcount} = $valence - $degree;
588             }
589             for (1..$atom->{hcount}) {
590             my $hydrogen = { symbol => 'H',
591             class => 0,
592             number => $self->{USER}{ATOMNO} };
593             $graph->add_edge( $atom, $hydrogen );
594             $self->{USER}{ATOMNO} ++;
595             if( $atom->{first_of_chain} ) {
596             _unshift_chirality_neighbour( $atom, $hydrogen );
597             } else {
598             _push_chirality_neighbour( $atom, $hydrogen );
599             }
600             }
601             delete $atom->{hcount};
602              
603             # Unify the representation of chirality
604             if( is_chiral $atom ) {
605             if( $atom->{chirality} =~ /^@@?$/ &&
606             $graph->degree( $atom ) == 2 ) {
607             $atom->{chirality} =~ s/@+/'@AL' . length $&/e;
608             }
609              
610             $atom->{chirality} =~ s/^\@TH1$/@/;
611             $atom->{chirality} =~ s/^\@TH2$/@@/;
612             }
613              
614             # Adjust chirality for centers having lone pairs
615             if( is_chiral $atom &&
616             $atom->{first_of_chain} &&
617             $atom->{chirality} =~ /^@@?$/ &&
618             $atom->{chirality_neighbours} &&
619             scalar @{$atom->{chirality_neighbours}} == 3 ) {
620             $atom->{chirality} = $atom->{chirality} eq '@' ? '@@' : '@';
621             }
622             }
623             delete $atom->{first_of_chain};
624             }
625             }
626              
627             return @graphs;
628             }
629              
630             sub _add_ring_bond
631             {
632             my( $self, $atom, $ring_bond, $bond ) = @_;
633             if( $self->{USER}{RINGBONDS}{$ring_bond} ) {
634             $self->_merge_graphs( $self->{USER}{RINGBONDS}{$ring_bond}{atom}{index},
635             $atom->{index} );
636              
637             if( $bond && $self->{USER}{RINGBONDS}{$ring_bond}{bond} &&
638             (($bond !~ /^[\\\/]$/ &&
639             $bond ne $self->{USER}{RINGBONDS}{$ring_bond}{bond}) ||
640             ($bond eq '\\' &&
641             $self->{USER}{RINGBONDS}{$ring_bond}{bond} ne '/') ||
642             ($bond eq '/' &&
643             $self->{USER}{RINGBONDS}{$ring_bond}{bond} ne '\\')) ) {
644             die "$0: ring bond types for ring bond $ring_bond do not match.\n";
645             }
646             ( $bond ) = grep { defined }
647             ( $self->{USER}{RINGBONDS}{$ring_bond}{bond}, $bond );
648              
649             if( $bond && $bond =~ /^[\\\/]$/ &&
650             !defined $self->{USER}{RINGBONDS}{$ring_bond}{bond} ) {
651             # If cis/trans marker is not specified when cis/trans bond is
652             # seen first, it has to be inverted:
653             $bond = toggle_cistrans $bond;
654             }
655              
656             my $ring_atom = $self->{USER}{RINGBONDS}{$ring_bond}{atom};
657             if( !$bond && is_aromatic $ring_atom && is_aromatic $atom ) {
658             $bond = ':';
659             }
660             if( $bond && $bond ne '-' ) {
661             $atom->{graph}->set_edge_attribute( $ring_atom,
662             $atom,
663             'bond',
664             $bond );
665             } else {
666             $atom->{graph}->add_edge( $ring_atom, $atom );
667             }
668             delete $self->{USER}{RINGBONDS}{$ring_bond};
669              
670             if( is_chiral $ring_atom && $ring_atom->{chirality_neighbours} ) {
671             my( $pos ) = grep { !ref $ring_atom->{chirality_neighbours}[$_] &&
672             $ring_atom->{chirality_neighbours}[$_] == $ring_bond }
673             0..$#{$ring_atom->{chirality_neighbours}};
674             $ring_atom->{chirality_neighbours}[$pos] = $atom if defined $pos;
675             }
676             _push_chirality_neighbour( $atom, $ring_atom );
677             } else {
678             $self->{USER}{RINGBONDS}{$ring_bond} =
679             { atom => $atom, $bond ? ( bond => $bond ) : () };
680              
681             # Record a placeholder for later addition of real chirality
682             # neighbour, which will be identified by the ring bond number
683             _push_chirality_neighbour( $atom, $ring_bond );
684             }
685             }
686              
687             sub _merge_graphs
688             {
689             my( $self, $index1, $index2 ) = @_;
690             return if $index1 == $index2;
691              
692             my $g1 = $self->{USER}{GRAPHS}[$index1];
693             my $g2 = $self->{USER}{GRAPHS}[$index2];
694              
695             for ($g2->vertices) {
696             $_->{graph} = $g1;
697             $_->{index} = $index1;
698             }
699             $g1->add_vertices( $g2->vertices );
700              
701             for ($g2->edges) {
702             my $attributes = $g2->get_edge_attributes( @$_ );
703             if( $attributes ) {
704             $g1->set_edge_attributes( @$_, $attributes );
705             } else {
706             $g1->add_edge( @$_ );
707             }
708             }
709              
710             $self->{USER}{GRAPHS}[$index2] = undef;
711             }
712              
713             sub _push_chirality_neighbour
714             {
715             my( $atom1, $atom2 ) = @_;
716             return unless is_chiral $atom1;
717             push @{$atom1->{chirality_neighbours}}, $atom2;
718             }
719              
720             sub _unshift_chirality_neighbour
721             {
722             my( $atom1, $atom2 ) = @_;
723             return unless is_chiral $atom1;
724             unshift @{$atom1->{chirality_neighbours}}, $atom2;
725             }
726              
727             1;
728              
729             1;