File Coverage

blib/lib/Chemistry/Elements.pm
Criterion Covered Total %
statement 139 140 99.2
branch 72 72 100.0
condition n/a
subroutine 32 32 100.0
pod 8 8 100.0
total 251 252 99.6


line stmt bran cond sub pod time code
1 19     19   13833 use v5.10;
  19         61  
2              
3             package Chemistry::Elements;
4              
5 19     19   108 use strict;
  19         31  
  19         443  
6 19     19   108 use warnings;
  19         32  
  19         751  
7 19     19   9883 use utf8;
  19         247  
  19         89  
8 19     19   528 no warnings;
  19         35  
  19         788  
9              
10 19     19   91 use Carp qw(croak carp);
  19         34  
  19         1120  
11 19     19   102 use Scalar::Util qw(blessed);
  19         34  
  19         926  
12              
13 19         1754 use vars qw( @ISA $AUTOLOAD
14             $debug %names %elements $maximum_Z
15             %names_to_Z $Default_language %Languages
16 19     19   101 );
  19         42  
17              
18 19     19   109 use Exporter qw(import);
  19         30  
  19         1672  
19              
20             our @EXPORT_OK = qw(get_Z get_symbol get_name);
21             our @EXPORT = qw();
22             our $VERSION = '1.075';
23              
24 19         90 use subs qw(
25             _get_name_by_Z
26             _get_symbol_by_Z
27             _get_name_by_symbol
28             _get_Z_by_symbol
29             _get_symbol_by_name
30             _get_Z_by_name
31             _is_Z
32             _is_name
33             _is_symbol
34             _format_name
35             _format_symbol
36 19     19   8597 );
  19         442  
37              
38 0         0 BEGIN {
39 19     19   4827 my @class_methods = qw(can isa);
40 19         64 my @object_methods = qw(new Z name symbol can);
41 19         49 my %class_methods = map { $_, 1 } @class_methods;
  38         135  
42 19         53 my %object_methods = map { $_, 1 } @object_methods;
  95         35833  
43              
44             sub can {
45 15     15 1 2069 my $thingy = shift;
46 15         38 my @methods = @_;
47              
48 15 100       79 my $method_hash = blessed $thingy ? \%object_methods : \%class_methods ;
49              
50 15         31 foreach my $method ( @methods ) {
51 15 100       123 return unless exists $method_hash->{ $method };
52             }
53              
54 7         34 return 1;
55             }
56              
57             sub _add_object_method { # everyone gets it
58 15     15   37 $object_methods{ $_[1] } = 1;
59             }
60             }
61              
62             $debug = 0;
63              
64             %Languages = (
65             'Pig Latin' => 0,
66             'English' => 1,
67             'Japanese' => 2,
68             );
69              
70             $Default_language = $Languages{'English'};
71              
72             # http://www.ptable.com/?lang=ja
73             %names = (
74             1 => [ qw( Ydrogenhai Hydrogen 水素) ],
75             2 => [ qw( Eliumhai Helium ヘリウム) ],
76             3 => [ qw( Ithiumlai Lithium リチウム) ],
77             4 => [ qw( Erylliumbai Beryllium ベリリウム) ],
78             5 => [ qw( Oronbai Boron ホウ素) ],
79             6 => [ qw( Arboncai Carbon 炭素) ],
80             7 => [ qw( Itrogennai Nitrogen 窒素) ],
81             8 => [ qw( Xygenoai Oxygen 酸素) ],
82             9 => [ qw( Luorinefai Fluorine フッ素) ],
83             10 => [ qw( Eonnai Neon ネオン) ],
84             11 => [ qw( Odiumsai Sodium ナトリウム) ],
85             12 => [ qw( Agnesiummai Magnesium マグネシウム) ],
86             13 => [ qw( Luminiumaai Aluminium アルミニウム) ],
87             14 => [ qw( Iliconsai Silicon ケイ素) ],
88             15 => [ qw( Hosphoruspai Phosphorus リン) ],
89             16 => [ qw( Ulfursai Sulfur 硫黄) ],
90             17 => [ qw( Hlorinecai Chlorine 塩素) ],
91             18 => [ qw( Rgonaai Argon アルゴン) ],
92             19 => [ qw( Otassiumpai Potassium カリウム) ],
93             20 => [ qw( Alciumcai Calcium カルシウム) ],
94             21 => [ qw( Candiumsai Scandium スカンジウム) ],
95             22 => [ qw( Itaniumtai Titanium チタン) ],
96             23 => [ qw( Anadiumvai Vanadium バナジウム) ],
97             24 => [ qw( Hromiumcai Chromium クロム) ],
98             25 => [ qw( Anganesemai Manganese マンガン) ],
99             26 => [ qw( Roniai Iron 鉄) ],
100             27 => [ qw( Obaltcai Cobalt コバルト) ],
101             28 => [ qw( Ickelnai Nickel ニッケル) ],
102             29 => [ qw( Oppercai Copper 銅) ],
103             30 => [ qw( Inczai Zinc 亜鉛) ],
104             31 => [ qw( Alliumgai Gallium ガリウム) ],
105             32 => [ qw( Ermaniumgai Germanium ゲルマニウム) ],
106             33 => [ qw( Rsenicaai Arsenic ヒ素) ],
107             34 => [ qw( Eleniumsai Selenium セレン) ],
108             35 => [ qw( Rominebai Bromine 臭素) ],
109             36 => [ qw( Ryptonkai Krypton クリプトン) ],
110             37 => [ qw( Ubidiumrai Rubidium ルビジウム) ],
111             38 => [ qw( Trontiumsai Strontium ストロンチウム) ],
112             39 => [ qw( Ttriumyai Yttrium イットリウム) ],
113             40 => [ qw( Irconiumzai Zirconium ジルコニウム) ],
114             41 => [ qw( Iobiumnai Niobium ニオブ) ],
115             42 => [ qw( Olybdenummai Molybdenum モリブデン) ],
116             43 => [ qw( Echnetiumtai Technetium テクネチウム) ],
117             44 => [ qw( Utheniumrai Ruthenium ルテニウム) ],
118             45 => [ qw( Hodiumrai Rhodium ロジウム) ],
119             46 => [ qw( Alladiumpai Palladium パラジウム) ],
120             47 => [ qw( Ilversai Silver 銀) ],
121             48 => [ qw( Admiumcai Cadmium カドミウム) ],
122             49 => [ qw( Ndiumiai Indium インジウム) ],
123             50 => [ qw( Intai Tin スズ) ],
124             51 => [ qw( Ntimonyaai Antimony アンチモン) ],
125             52 => [ qw( Elluriumtai Tellurium テルル) ],
126             53 => [ qw( Odineiai Iodine ヨウ素) ],
127             54 => [ qw( Enonxai Xenon キセノン) ],
128             55 => [ qw( Esiumcai Cesium セシウム) ],
129             56 => [ qw( Ariumbai Barium バリウム) ],
130             57 => [ qw( Anthanumlai Lanthanum ランタン) ],
131             58 => [ qw( Eriumcai Cerium セリウム) ],
132             59 => [ qw( Raesodymiumpai Praseodymium プラセオジム) ],
133             60 => [ qw( Eodymiumnai Neodymium ネオジム) ],
134             61 => [ qw( Romethiumpai Promethium プロメチウム) ],
135             62 => [ qw( Amariumsai Samarium サマリウム) ],
136             63 => [ qw( Uropiumeai Europium ユウロピウム) ],
137             64 => [ qw( Adoliniumgai Gadolinium ガドリニウム) ],
138             65 => [ qw( Erbiumtai Terbium テルビウム) ],
139             66 => [ qw( Ysprosiumdai Dysprosium ジスプロシウム) ],
140             67 => [ qw( Olmiumhai Holmium ホルミウム) ],
141             68 => [ qw( Rbiumeai Erbium エルビウム) ],
142             69 => [ qw( Huliumtai Thulium ツリウム) ],
143             70 => [ qw( Tterbiumyai Ytterbium イッテルビウム) ],
144             71 => [ qw( Utetiumlai Lutetium ルテチウム) ],
145             72 => [ qw( Afniumhai Hafnium ハフニウム) ],
146             73 => [ qw( Antalumtai Tantalum タンタル) ],
147             74 => [ qw( Ungstentai Tungsten タングステン) ],
148             75 => [ qw( Heniumrai Rhenium レニウム) ],
149             76 => [ qw( Smiumoai Osmium オスミウム) ],
150             77 => [ qw( Ridiumiai Iridium イリジウム) ],
151             78 => [ qw( Latinumpai Platinum 白金) ],
152             79 => [ qw( Oldgai Gold 金) ],
153             80 => [ qw( Ercurymai Mercury 水銀) ],
154             81 => [ qw( Halliumtai Thallium タリウム) ],
155             82 => [ qw( Eadlai Lead 鉛) ],
156             83 => [ qw( Ismuthbai Bismuth ビスマス) ],
157             84 => [ qw( Oloniumpai Polonium ポロニウム) ],
158             85 => [ qw( Statineaai Astatine アスタチン) ],
159             86 => [ qw( Adonrai Radon ラドン) ],
160             87 => [ qw( Ranciumfai Francium フランシウム) ],
161             88 => [ qw( Adiumrai Radium ラジウム) ],
162             89 => [ qw( Ctiniumaai Actinium アクチニウム) ],
163             90 => [ qw( Horiumtai Thorium トリウム) ],
164             91 => [ qw( Rotactiniumpai Protactinium プロトアクチニウム) ],
165             92 => [ qw( Raniumuai Uranium ウラン) ],
166             93 => [ qw( Eptuniumnai Neptunium ネプツニウム) ],
167             94 => [ qw( Lutoniumpai Plutonium プルトニウム) ],
168             95 => [ qw( Mericiumaai Americium アメリシウム) ],
169             96 => [ qw( Uriumcai Curium キュリウム) ],
170             97 => [ qw( Erkeliumbai Berkelium バークリウム) ],
171             98 => [ qw( Aliforniumcai Californium カリホルニウム) ],
172             99 => [ qw( Insteiniumeai Einsteinium アインスタイニウム) ],
173             100 => [ qw( Ermiumfai Fermium フェルミウム) ],
174             101 => [ qw( Endeleviummai Mendelevium メンデレビウム) ],
175             102 => [ qw( Obeliumnai Nobelium ノーベリウム) ],
176             103 => [ qw( Awerenciumlai Lawrencium ローレンシウム) ],
177             104 => [ qw( Utherfordiumrai Rutherfordium ラザホージウム) ],
178             105 => [ qw( Ubniumdai Dubnium ドブニウム) ],
179             106 => [ qw( Eaborgiumsai Seaborgium シーボーギウム) ],
180             107 => [ qw( Ohriumbai Bohrium ボーリウム) ],
181             108 => [ qw( Assiumhai Hassium ハッシウム) ],
182             109 => [ qw( Eitneriummai Meitnerium マイトネリウム) ],
183             110 => [ qw( Armstadtiumdai Darmstadtium ダームスタチウム) ],
184             111 => [ qw( Oentgeniumrai Roentgenium レントゲニウム) ],
185             112 => [ qw( Operniciumcai Copernicium コペルニシウム) ],
186             113 => [ qw( Ihoniumnai Nihonium ニホニウム) ],
187             114 => [ qw( Leroviumfai Flerovium フレロビウム) ],
188             115 => [ qw( Oscoviummai Moscovium モスコビウム) ],
189             116 => [ qw( Ivermoriumlai Livermorium リバモリウム) ],
190             117 => [ qw( Ennessinetai Tennessine テネシン) ],
191             118 => [ qw( Ganessonoai Oganesson オガネソン) ],
192             );
193              
194             {
195             # There might be duplicates keys here, but it should never come out
196             # with the wrong Z
197             our %names_to_Z = ();
198             foreach my $Z ( keys %names ) {
199             my @names = map { lc } @{ $names{$Z} };
200             # print STDERR "Got names [@names] for $Z\n";
201             @names_to_Z{@names} = ($Z) x @names;
202             }
203              
204             #print STDERR Dumper( \%names_to_symbol ); use Data::Dumper;
205             }
206              
207             {
208             my @a = sort {$a <=> $b } keys %names;
209             $maximum_Z = pop @a;
210             }
211              
212             my %elements = map { state $n = 0; $n++; $_ => $n, $n => $_ } qw(
213             H He
214             Li Be B C N O F Ne
215             Na Mg Al Si P S Cl Ar
216             K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr
217             Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe
218             Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn
219             Fr Ra Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr Rf Ha Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og
220             );
221              
222             sub new {
223 16     16 1 7046 my( $class, $data, $language ) = @_;
224              
225 16         35 my $self = {};
226 16         36 bless $self, $class;
227              
228 16 100       46 if( _is_Z $data ) { $self->Z($data) }
  1 100       3  
    100          
229 5         19 elsif( _is_symbol $data ) { $self->symbol($data) }
230 4         15 elsif( _is_name $data ) { $self->name($data) }
231 6         40 else { return }
232              
233 10         33 return $self;
234             }
235              
236             sub Z {
237 30     30 1 1529 my $self = shift;
238              
239 30 100       127 return $self->{'Z'} unless @_;
240 8         13 my $data = shift;
241              
242 8 100       22 unless( _is_Z $data ) {
243 6         41 $self->error('$data is not a valid proton number');
244 6         26 return;
245             }
246              
247 2         6 $self->{'Z'} = $data;
248 2         17 $self->{'name'} = _get_name_by_Z $data;
249 2         7 $self->{'symbol'} = _get_symbol_by_Z $data;
250              
251 2         8 return $data;
252             }
253              
254             sub name {
255 20     20 1 40 my $self = shift;
256              
257 20 100       85 return $self->{'name'} unless @_;
258 9         14 my $data = shift;
259              
260 9 100       24 unless( _is_name $data ) {
261 4         29 $self->error('$data is not a valid element name');
262 4         17 return;
263             }
264              
265 5         35 $self->{'name'} = _format_name $data;
266 5         22 $self->{'Z'} = _get_Z_by_name $data;
267 5         19 $self->{'symbol'} = _get_symbol_by_Z($self->Z);
268              
269 5         12 return $data;
270             }
271              
272             sub symbol {
273 21     21 1 37 my $self = shift;
274              
275 21 100       87 return $self->{'symbol'} unless @_;
276 10         19 my $data = shift;
277              
278 10 100       26 unless( _is_symbol $data ) {
279 4         24 $self->error('$data is not a valid element symbol');
280 4         19 return;
281             }
282              
283 6         16 $self->{'symbol'} = _format_symbol $data;
284 6         26 $self->{'Z'} = _get_Z_by_symbol $data;
285 6         18 $self->{'name'} = _get_name_by_Z $self->Z;
286              
287 6         14 return $data;
288             }
289              
290             sub get_symbol {
291 12     12 1 709 my $thingy = shift;
292              
293             #since we were asked for a name, we'll suppose that we were passed
294             #either a chemical symbol or a Z.
295 12 100       27 return _get_symbol_by_Z($thingy) if _is_Z $thingy;
296 11 100       24 return _get_symbol_by_name($thingy) if _is_name $thingy;
297              
298             #maybe it's already a symbol...
299 9 100       16 return _format_symbol $thingy if _is_symbol $thingy;
300              
301             #we were passed something wierd. pretend we don't know anything.
302 8         29 return;
303             }
304              
305             sub _get_symbol_by_name {
306 12     12   714 my $name = lc shift;
307              
308 12 100       19 return unless _is_name $name;
309              
310 8         14 my $Z = $names_to_Z{$name};
311              
312 8         30 $elements{$Z};
313             }
314              
315             sub _get_symbol_by_Z {
316 15 100   15   754 return unless _is_Z $_[0];
317              
318 11         51 return $elements{$_[0]};
319             }
320              
321             sub get_name {
322 17     17 1 850 my $thingy = shift;
323 17 100       39 my $language = defined $_[0] ? $_[0] : $Default_language;
324              
325             #since we were asked for a name, we'll suppose that we were passed
326             #either a chemical symbol or a Z.
327 17 100       34 return _get_name_by_symbol( $thingy, $language ) if _is_symbol $thingy;
328 14 100       22 return _get_name_by_Z( $thingy, $language ) if _is_Z $thingy;
329              
330             #maybe it's already a name, might have to translate it
331 11 100       22 if( _is_name $thingy )
332             {
333 3         7 my $Z = _get_Z_by_name( $thingy );
334 3         6 return _get_name_by_Z( $Z, $language );
335             }
336              
337             #we were passed something wierd. pretend we don't know anything.
338 8         28 return;
339             }
340              
341              
342             sub _get_name_by_symbol {
343 16     16   719 my $symbol = shift;
344              
345 16 100       27 return unless _is_symbol $symbol;
346              
347 12 100       23 my $language = defined $_[0] ? $_[0] : $Default_language;
348              
349 12         20 my $Z = _get_Z_by_symbol($symbol);
350              
351 12         20 return _get_name_by_Z( $Z, $language );
352             }
353              
354             sub _get_name_by_Z {
355 36     36   770 my $Z = shift;
356 36 100       71 my $language = defined $_[0] ? $_[0] : $Default_language;
357              
358 36 100       60 return unless _is_Z $Z;
359              
360             #not much we can do if they don't pass a proper number
361             # XXX: check for language?
362 34         149 return $names{$Z}[$language];
363             }
364              
365             sub get_Z {
366 13     13 1 692 my $thingy = shift;
367              
368 13 100       305 croak "Can't call get_Z on object. Use Z instead" if ref $thingy;
369              
370             #since we were asked for a name, we'll suppose that we were passed
371             #either a chemical symbol or a Z.
372 11 100       23 return _get_Z_by_symbol( $thingy ) if _is_symbol( $thingy );
373 10 100       19 return _get_Z_by_name( $thingy ) if _is_name( $thingy );
374              
375             #maybe it's already a Z
376 9 100       16 return $thingy if _is_Z( $thingy );
377              
378 8         31 return;
379             }
380              
381             # gets the proton number for the name, no matter which language it
382             # is in
383             sub _get_Z_by_name {
384 19     19   6049 my $name = lc shift;
385              
386 19         49 $names_to_Z{$name}; # language agnostic
387             }
388              
389             sub _get_Z_by_symbol {
390 28     28   931 my $symbol = _format_symbol( shift );
391              
392 28 100       103 return $elements{$symbol} if exists $elements{$symbol};
393              
394 4         14 return;
395             }
396              
397             ########################################################################
398             ########################################################################
399             #
400             # the _is_* functions do some minimal data checking to help other
401             # functions guess what sort of input they received
402              
403             ########################################################################
404 69 100   69   1833 sub _is_name { exists $names_to_Z{ lc shift } ? 1 : 0 }
405              
406             ########################################################################
407             sub _is_symbol {
408 85     85   1618 my $symbol = _format_symbol( $_[0] );
409              
410 85 100       304 exists $elements{$symbol} ? 1 : ();
411             }
412              
413             ########################################################################
414 232 100   232   41409 sub _is_Z { $_[0] =~ /^[123456789]\d*\z/ && exists $elements{$_[0]} }
415              
416             ########################################################################
417             # _format_symbol
418             #
419             # input: a string that is supoosedly a chemical symbol
420             # output: the string with the first character in uppercase and the
421             # rest lowercase
422             #
423             # there is no data checking involved. this function doens't know
424             # and doesn't care if the data are valid. it just does its thing.
425 120 100   120   638 sub _format_symbol { $_[0] =~ m/^[a-z]/i && ucfirst lc $_[0] }
426              
427             ########################################################################
428             # _format_name
429             #
430             # input: a string that is supoosedly a chemical element's name
431             # output: the string with the first character in uppercase and the
432             # rest lowercase
433             #
434             # there is no data checking involved. this function doens't know
435             # and doesn't care if the data are valid. it just does its thing.
436             #
437             # this looks like _format_symbol, but it logically isn't. someday
438             # it might do something different than _format_symbol
439             sub _format_name {
440 5     5   23 my $data = shift;
441              
442 5         37 $data =~ s/^(.)(.*)/uc($1).lc($2)/e;
  5         43  
443              
444 5         35 return $data;
445             }
446              
447             ########################################################################
448             sub AUTOLOAD {
449 42     42   3997 my $self = shift;
450 42         58 my $data = shift;
451              
452 42 100       226 return unless ref $self;
453              
454 32         57 my $method_name = $AUTOLOAD;
455              
456 32         167 $method_name =~ s/.*:://;
457              
458 32 100       116 if( $data )
    100          
459             { # only add new method if they add data
460 15         26 $self->{$method_name} = $data;
461 15         34 $self->_add_object_method( $method_name );
462             }
463 1         5 elsif( defined $self->{$method_name} ) { return $self->{$method_name} }
464 16         628 else { return }
465              
466             }
467              
468             1;
469              
470             __END__