File Coverage

blib/lib/Physics/Unit.pm
Criterion Covered Total %
statement 318 348 91.3
branch 146 192 76.0
condition 27 45 60.0
subroutine 42 47 89.3
pod 29 42 69.0
total 562 674 83.3


line stmt bran cond sub pod time code
1             package Physics::Unit;
2              
3 2     2   14737 use strict;
  2         3  
  2         45  
4 2     2   6 use warnings;
  2         2  
  2         39  
5 2     2   5 use Carp;
  2         3  
  2         123  
6 2     2   8 use base qw(Exporter);
  2         3  
  2         162  
7 2         7300 use vars qw(
8             $VERSION
9             @EXPORT_OK
10             %EXPORT_TAGS
11             $debug
12             $number_re
13 2     2   7 );
  2         1  
14              
15             $VERSION = '0.54';
16             $VERSION = eval $VERSION;
17              
18             @EXPORT_OK = qw(
19             $number_re
20             GetTypeUnit
21             GetUnit
22             InitBaseUnit
23             InitPrefix
24             InitTypes
25             InitUnit
26             ListTypes
27             ListUnits
28             NumBases
29             DeleteNames
30             );
31              
32             %EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
33              
34             # This is the regular expression used to parse out a number. It
35             # is here so that other modules can use it for convenience.
36              
37             $number_re = '([-+]?((\d+\.?\d*)|(\.\d+))([eE][-+]?((\d+\.?\d*)|(\.\d+)))?)';
38              
39             # The value of this hash is a string representing the token returned
40             # when this word is seen
41              
42             my %reserved_word = (
43             per => 'divide',
44             square => 'square',
45             sq => 'square',
46             cubic => 'cubic',
47             squared => 'squared',
48             cubed => 'cubed',
49             );
50              
51             # Pre-defined units
52             my %unit_by_name;
53              
54             # Values are references to units representing the prefix
55             my %prefix;
56              
57             # Known quantity types. The values of this hash are references to
58             # unit objects that exemplify these types
59             my %prototype;
60              
61             # The number of base units
62             my $NumBases = 0;
63              
64             # The names of the base units
65             my @BaseName;
66              
67             InitBaseUnit (
68             'Distance' => ['meter', 'm', 'meters', 'metre', 'metres'],
69             'Mass' => ['gram', 'gm', 'grams'],
70             'Time' => ['second', 's', 'sec', 'secs', 'seconds'],
71             'Temperature' => ['kelvin', 'k', 'kelvins',
72             'degree-kelvin', 'degrees-kelvin', 'degree-kelvins'],
73             'Current' => ['ampere', 'amp', 'amps', 'amperes'],
74             'Substance' => ['mole', 'mol', 'moles'],
75             'Luminosity' => ['candela', 'cd', 'candelas', 'candle', 'candles'],
76             'Money' => ['us-dollar', 'dollar', 'dollars', 'us-dollars', '$'],
77             'Data' => ['bit', 'bits'],
78             );
79              
80             InitPrefix (
81             'deka', 1e1,
82             'deca', 1e1,
83             'hecto', 1e2,
84             'kilo', 1e3,
85             'mega', 1e6,
86             'giga', 1e9,
87             'tera', 1e12,
88             'peta', 1e15,
89             'exa', 1e18,
90             'zetta', 1e21,
91             'yotta', 1e24,
92             'deci', 1e-1,
93             'centi', 1e-2,
94             'milli', 1e-3,
95             'micro', 1e-6,
96             'nano', 1e-9,
97             'pico', 1e-12,
98             'femto', 1e-15,
99             'atto', 1e-18,
100             'zepto', 1e-21,
101             'yocto', 1e-24,
102              
103             # binary prefixes
104             'kibi', 2**10,
105             'mebi', 2**20,
106             'gibi', 2**30,
107             'tebi', 2**40,
108             'pebi', 2**50,
109             'exbi', 2**60,
110              
111             # others
112             'semi', 0.5,
113             'demi', 0.5,
114             );
115              
116              
117             InitUnit (
118             # Dimensionless
119             ['pi',], '3.1415926535897932385',
120             ['e',], '2.7182818284590452354',
121              
122             ['unity', 'one', 'ones',], '1',
123             ['two', 'twos',], '2',
124             ['three', 'threes',], '3',
125             ['four', 'fours',], '4',
126             ['five', 'fives',], '5',
127             ['six', 'sixes',], '6',
128             ['seven', 'sevens',], '7',
129             ['eight', 'eights',], '8',
130             ['nine', 'nines'], '9',
131             ['ten', 'tens',], '10',
132             ['eleven', 'elevens',], '11',
133             ['twelve', 'twelves',], '12',
134             ['thirteen', 'thirteens',], '13',
135             ['fourteen', 'fourteens',], '14',
136             ['fifteen', 'fifteens',], '15',
137             ['sixteen', 'sixteens',], '16',
138             ['seventeen', 'seventeens',], '17',
139             ['eighteen', 'eighteens',], '18',
140             ['nineteen', 'nineteens',], '19',
141             ['twenty', 'twenties',], '20',
142             ['thirty', 'thirties',], '30',
143             ['forty', 'forties',], '40',
144             ['fifty', 'fifties',], '50',
145             ['sixty', 'sixties',], '60',
146             ['seventy', 'seventies',], '70',
147             ['eighty', 'eighties',], '80',
148             ['ninety', 'nineties',], '90',
149             ['hundred', 'hundreds'], '100',
150             ['thousand', 'thousands'], '1000',
151             ['million', 'millions',], '1e6',
152             ['billion', 'billions',], '1e9',
153             ['trillion', 'trillions',], '1e12',
154             ['quadrillion', 'quadrillions',], '1e15',
155             ['quintillion', 'quintillions',], '1e18',
156              
157             ['half', 'halves',], '0.5',
158             ['third', 'thirds',], '1/3',
159             ['fourth', 'fourths',], '0.25',
160             ['tenth',], '0.1',
161             ['hundredth',], '0.01',
162             ['thousandth',], '0.001',
163             ['millionth',], '1e-6',
164             ['billionth',], '1e-9',
165             ['trillionth',], '1e-12',
166             ['quadrillionth',], '1e-15',
167             ['quintillionth',], '1e-18',
168              
169             ['percent', '%',], '0.01',
170             ['dozen', 'doz',], '12',
171             ['gross',], '144',
172              
173             # Angular
174             ['radian', 'radians',], '1',
175             ['steradian', 'sr', 'steradians',], '1',
176             ['degree', 'deg', 'degrees',], 'pi radians / 180',
177             ['arcminute', 'arcmin', 'arcminutes',], 'deg / 60',
178             ['arcsecond', 'arcsec', 'arcseconds',], 'arcmin / 60',
179              
180             # Distance
181             ['foot', 'ft', 'feet',], '.3048 m', # exact
182             ['inch', 'in', 'inches',], 'ft/12', # exact
183             ['mil', 'mils',], 'in/1000', # exact
184             ['yard', 'yards',], '3 ft', # exact
185             ['fathom', 'fathoms',], '2 yards', # exact
186             ['rod', 'rods',], '5.5 yards', # exact
187             ['pole', 'poles',], '1 rod', # exact
188             ['perch', 'perches',], '1 rod', # exact
189             ['furlong', 'furlongs',], '40 rods', # exact
190             ['mile', 'mi', 'miles',], '5280 ft', # exact
191              
192             ['micron', 'microns', 'um',], '1e-6 m', # exact
193             ['angstrom', 'a', 'angstroms',], '1e-10 m', # exact
194             ['cm',], 'centimeter', # exact
195             ['km',], 'kilometer', # exact
196             ['nm',], 'nanometer', # exact
197             ['mm',], 'millimeter', # exact
198              
199             ['pica',], 'in/6', # exact, but see below
200             ['point',], 'pica/12', # exact
201              
202             ['nautical-mile', 'nmi', 'nauticalmiles',
203             'nauticalmile', 'nautical-miles',], '1852 m', # exact
204             ['astronomical-unit', 'au',], '1.49598e11 m',
205             ['light-year', 'ly', 'light-years',
206             'lightyear', 'lightyears'], '9.46e15 m',
207             ['parsec', 'parsecs',], '3.083e16 m',
208              
209             # equatorial radius of the reference geoid:
210             ['re'], '6378388 m', # exact
211             # polar radius of the reference geoid:
212             ['rp'], '6356912 m', # exact
213              
214             # Acceleration
215             ['g0', 'earth-gravity'], '9.80665 m/s^2', # exact
216              
217             # Mass
218             ['kg',], 'kilogram', # exact
219             ['metric-ton', 'metric-tons', 'tonne',
220             'tonnes'], '1000 kg', # exact
221              
222             ['grain', 'grains'], '.0648 gm',
223              
224             ['pound-mass', 'lbm', 'lbms',
225             'pounds-mass'], '0.45359237 kg', # exact
226             ['ounce', 'oz', 'ounces'], 'lbm/16', # exact
227             ['stone', 'stones'], '14 lbm', # exact
228             ['hundredweight', 'hundredweights'], '100 lbms', # exact
229             ['ton', 'tons', 'short-ton', 'short-tons'], '2000 lbms', # exact
230             ['long-ton', 'long-tons'], '2240 lbms', # exact
231              
232             ['slug', 'slugs'], 'lbm g0 s^2/ft', # exact
233             ['mg',], 'milligram', # exact
234             ['ug',], 'microgram', # exact
235              
236             ['dram', 'drams'], 'ounce / 16', # exact
237              
238             ['troy-pound', 'troy-pounds'], '0.373 kg',
239             ['troy-ounce', 'troy-ounces',
240             'ounce-troy', 'ounces-troy'], '31.103 gm',
241             ['pennyweight', 'pennyweights'], '1.555 gm',
242             ['scruple', 'scruples'], '1.296 gm',
243              
244             ['hg',], 'hectogram', # exact
245             ['dag',], 'decagram', # exact
246             ['dg',], 'decigram', # exact
247             ['cg',], 'centigram', # exact
248             ['carat', 'carats', 'karat', 'karats',], '200 milligrams', # exact
249             ['j-point',], '2 carats', # exact
250              
251             ['atomic-mass-unit', 'amu', 'u',
252             'atomic-mass-units'], '1.6605402e-27 kg',
253              
254              
255             # Time
256             ['minute', 'min', 'mins', 'minutes'], '60 s',
257             ['hour', 'hr', 'hrs', 'hours'], '60 min',
258             ['day', 'days'], '24 hr',
259             ['week', 'wk', 'weeks'], '7 days',
260             ['fortnight', 'fortnights'], '2 week',
261             ['year', 'yr', 'yrs', 'years'], '365.25 days',
262             ['month', 'mon', 'mons', 'months'], 'year / 12', # an average month
263             ['score', 'scores'], '20 yr',
264             ['century', 'centuries'], '100 yr',
265             ['millenium', 'millenia',], '1000 yr',
266              
267             ['ms', 'msec', 'msecs'], 'millisecond',
268             ['us', 'usec', 'usecs'], 'microsecond',
269             ['ns', 'nsec', 'nsecs'], 'nanosecond',
270             ['ps', 'psec', 'psecs'], 'picosecond',
271              
272             # Data
273             ['byte', 'bytes'], '8 bits',
274              
275             # Frequency
276             ['hertz', 'hz'], '1/sec',
277             ['becquerel', 'bq'], '1 hz',
278             ['revolution', 'revolutions',], '1',
279             ['rpm',], 'revolutions per minute',
280             ['cycle', 'cycles',], '1',
281              
282             # Current
283             ['abampere', 'abamp', 'abamps', 'abamperes'], '10 amps',
284             ['statampere', 'statamp', 'statamps', 'statamperes'], '3.336e-10 amps',
285              
286             ['ma',], 'milliamp',
287             ['ua',], 'microamp',
288              
289             # Electric_potential
290             ['volt', 'v', 'volts'], 'kg m^2 / amp s^3',
291             ['mv',], 'millivolt',
292             ['uv',], 'microvolt',
293             ['abvolt', 'abvolts'], '1e-8 volt',
294             ['statvolt', 'statvolts'], '299.8 volt',
295              
296             # Resistance
297             ['ohm', 'ohms'], 'kg m^2 / amp^2 s^3',
298             ['abohm', 'abohms'], 'nano ohm',
299             ['statohm', 'statohms'], '8.987e11 ohm',
300             ['kilohm', 'kilohms',], 'kilo ohm',
301             ['megohm', 'megohms'], 'mega ohm',
302              
303             # Conductance
304             ['siemens',], 'amp^2 s^3 / kg m^2',
305             ['mho', 'mhos'], '1/ohm',
306              
307             # Capacitance
308             ['farad', 'f', 'farads'], 'amp^2 s^4 / kg m^2',
309             ['abfarad', 'abfarads'], 'giga farad',
310             ['statfarad', 'statfarads'], '1.113e-12 farad',
311              
312             ['uf',], 'microfarad',
313             ['pf',], 'picofarads',
314              
315             # Inductance
316             ['henry', 'henrys'], 'kg m^2 / amp^2 s^2',
317             ['abhenry', 'abhenrys'], 'nano henry',
318             ['stathenry', 'stathenrys'], '8.987e11 henry',
319              
320             ['uh',], 'microhenry',
321             ['mh',], 'millihenry',
322              
323             # Magnetic_flux
324             ['weber', 'wb', 'webers'], 'kg m^2 / amp s^2',
325             ['maxwell', 'maxwells'], '1e-8 weber',
326              
327             # Magnetic_field
328             ['tesla', 'teslas'], 'kg / amp sec^2',
329             ['gauss',], '1e-4 tesla',
330              
331             # Temperature
332             ['degree-rankine', 'degrees-rankine'], '5/9 * kelvin', # exact
333              
334             # Force
335             ['pound', 'lb', 'lbs', 'pounds',
336             'pound-force', 'lbf',
337             'pounds-force', 'pound-weight'], 'slug foot / s^2', # exact
338             ['ounce-force', 'ozf'], 'pound-force / 16', # exact
339             ['newton', 'nt', 'newtons'], 'kg m / s^2', # exact
340             ['dyne', 'dynes'], 'gm cm / s^2', # exact
341             ['gram-weight', 'gram-force'], 'gm g0', # exact
342             ['kgf',], 'kilo gram-force', # exact
343              
344             # Area
345             ['are', 'ares'], '100 square meters',
346             ['hectare', 'hectares',], '100 ares',
347             ['acre', 'acres'], '43560 square feet',
348             ['barn', 'barns'], '1e-28 square meters',
349              
350             # Volume
351             ['liter', 'l', 'liters'], 'm^3/1000', # exact
352             ['cl',], 'centiliter', # exact
353             ['dl',], 'deciliter', # exact
354             ['cc', 'ml',], 'cubic centimeter', # exact
355              
356             ['gallon', 'gal', 'gallons'], '3.785411784 liter',
357             ['quart', 'qt', 'quarts'], 'gallon/4',
358             ['peck', 'pecks'], '8 quarts',
359             ['bushel', 'bushels'], '4 pecks',
360             ['fifth', 'fifths'], 'gallon/5',
361             ['pint', 'pt', 'pints'], 'quart/2',
362             ['cup', 'cups'], 'pint/2',
363             ['fluid-ounce', 'floz', 'fluidounce',
364             'fluidounces', 'fluid-ounces'], 'cup/8',
365             ['gill', 'gills'], '4 fluid-ounces',
366             ['fluidram', 'fluidrams'], '3.5516 cc',
367             ['minim', 'minims'], '0.059194 cc',
368             ['tablespoon', 'tbsp', 'tablespoons'], 'fluid-ounce / 2',
369             ['teaspoon', 'tsp', 'teaspoons'], 'tablespoon / 3',
370              
371             # Power
372             ['watt', 'w', 'watts'], 'kg m^2 / s^3',
373             ['horsepower', 'hp'], '550 foot pound-force / s',
374              
375             # Energy
376             ['joule', 'j', 'joules'], 'kg m^2 / s^2', # exact
377             ['electron-volt', 'ev', 'electronvolt',
378             'electronvolts', 'electron-volts'], '1.60217733e-19 joule',
379              
380             ['mev',], 'mega electron-volt',
381             ['gev',], 'giga electron-volt',
382             ['tev',], 'tera electron-volt',
383              
384             ['calorie', 'cal', 'calories'], '4.184 joules', # exact
385             ['kcal',], 'kilocalorie', # exact
386             ['british-thermal-unit', 'btu', 'btus',
387             'britishthermalunit', 'britishthermalunits',
388             'british-thermal-units'], '1055.056 joule',
389             ['erg', 'ergs'], '1.0e-7 joule', # exact
390             ['kwh',], 'kilowatt hour', # exact
391              
392             # Torque
393             ['foot-pound', 'ftlb', 'ft-lb',
394             'footpound', 'footpounds', 'foot-pounds'], 'foot pound-force',
395              
396             # Charge
397             ['coulomb', 'coul', 'coulombs'], 'ampere second',
398             ['abcoulomb', 'abcoul', 'abcoulombs'], '10 coulomb',
399             ['statcoulomb', 'statcoul', 'statcoulombs'], '3.336e-10 coulomb',
400             ['elementary-charge', 'eq'], '1.6021892e-19 coulomb',
401              
402             # Pressure
403             ['pascal', 'pa'], 'newton / m^2',
404             ['bar', 'bars'], '1e5 pascal',
405             ['torr',], '(101325 / 760) pascal',
406             ['psi',], 'pounds per inch^2',
407             ['atmosphere', 'atm'], '101325 pascal', # exact
408              
409             # Speed
410             ['mph',], 'mi/hr',
411             ['kph',], 'km/hr',
412             ['kps',], 'km/s',
413             ['fps',], 'ft/s',
414             ['knot', 'knots'], 'nm/hr',
415             ['mps',], 'meter/s',
416             ['speed-of-light', 'c'], '2.99792458e8 m/sec',
417              
418             # Dose of radiation
419             ['gray', 'gy'], 'joule / kg',
420             ['sievert', 'sv'], 'joule / kg',
421             ['rad',], 'gray / 100',
422             ['rem',], 'sievert / 100',
423              
424             # Other
425             ['gravitational-constant', 'g'], '6.6720e-11 m^3 / kg s^2',
426             # Planck constant:
427             ['h'], '6.626196e-34 J/s',
428             # Avogadro constant:
429             ['na'], '6.022169/mol',
430             );
431              
432              
433             InitTypes (
434             'Dimensionless' => 'unity',
435             'Frequency' => 'hertz',
436             'Electric_potential' => 'volt',
437             'Resistance' => 'ohm',
438             'Conductance' => 'siemens',
439             'Capacitance' => 'farad',
440             'Inductance' => 'henry',
441             'Magnetic_flux' => 'weber',
442             'Magnetic_field' => 'tesla',
443             'Momentum' => 'kg m/s',
444             'Force' => 'newton',
445             'Area' => 'are',
446             'Volume' => 'liter',
447             'Power' => 'watt',
448             'Energy' => 'joule',
449             'Torque' => 'kg m^2/s^2',
450             'Charge' => 'coulomb',
451             'Pressure' => 'pascal',
452             'Speed' => 'mps',
453             'Dose' => 'gray', # of radiation
454             'Acceleration' => 'm/s^2',
455             );
456              
457              
458             GetUnit('joule')->type('Energy');
459             GetUnit('ev')->type('Energy');
460             GetUnit('mev')->type('Energy');
461             GetUnit('gev')->type('Energy');
462             GetUnit('tev')->type('Energy');
463             GetUnit('cal')->type('Energy');
464             GetUnit('kcal')->type('Energy');
465             GetUnit('btu')->type('Energy');
466             GetUnit('erg')->type('Energy');
467             GetUnit('kwh')->type('Energy');
468             GetUnit('ftlb')->type('Torque');
469              
470              
471             sub InitBaseUnit {
472 3     3 1 10 while (@_) {
473 19         23 my ($t, $names) = (shift, shift);
474 19 50 33     72 croak 'Invalid arguments to InitBaseUnit'
475             if ref $t || (ref $names ne "ARRAY");
476              
477 19 50       24 print "Initializing Base Unit $$names[0]\n" if $debug;
478              
479 19         23 my $unit = NewOne();
480 19         33 $unit->AddNames(@$names);
481 19         25 $unit->{def} = $unit->name(); # def same as name
482              
483             # The dimension vector for this Unit has zeros in every place
484             # except the last
485 19         19 $unit->{dim}->[$NumBases] = 1;
486 19         22 $BaseName[$NumBases] = $unit->abbr();
487 19         17 $NumBases++;
488              
489 19         24 $unit->NewType($t);
490             }
491             }
492              
493             sub InitPrefix {
494 3     3 1 9 while (@_) {
495 60         51 my ($name, $factor) = (shift, shift);
496 60 50 33     308 croak 'Invalid arguments to InitPrefix'
      33        
      33        
497             if !$name || !$factor || ref $name || ref $factor;
498              
499 60 50       63 print "Initializing Prefix $name\n" if $debug;
500              
501 60         54 my $u = NewOne();
502 60         61 $u->AddNames($name);
503 60         52 $u->{factor} = $factor;
504 60         44 $u->{type} = 'prefix';
505 60         46 $prefix{$name} = $u;
506              
507 60         89 $u->{def} = $factor;
508             }
509             }
510              
511             sub InitUnit {
512 6     6 1 21 while (@_) {
513 440         494 my ($names, $def) = (shift, shift);
514              
515 440 50 33     1303 if (ref $names ne "ARRAY" || !$def) {
516 0         0 print "InitUnit, second argument is '$def'\n";
517 0         0 croak 'Invalid arguments to InitUnit';
518             }
519              
520 440 50       495 print "Initializing Unit $$names[0]\n" if $debug;
521 440         429 my $u = CreateUnit($def);
522 440         587 $u->AddNames(@$names);
523             }
524             }
525              
526             sub InitTypes {
527 3     3 1 12 while (@_) {
528 43         40 my ($t, $u) = (shift, shift);
529 43 50 33     182 croak 'Invalid arguments to InitTypes'
      33        
530             if !$t || ref $t || !$u;
531              
532 43         43 my $unit = GetUnit($u);
533 43         49 $unit->NewType($t);
534             }
535             }
536              
537             sub GetUnit {
538 1382     1382 1 2027 my $u = shift;
539 1382 50       1628 croak 'GetUnit: expected an argument' unless $u;
540 1382 100       1902 return $u if ref $u;
541              
542 748 100       1070 if ($unit_by_name{$u}) {
543             #print "GetUnit, $u yields ", $unit_by_name{$u}->name, "\n";
544 721         1110 return $unit_by_name{$u};
545             }
546              
547             # Try it as an expression
548 27         39 return CreateUnit($u);
549             }
550              
551             sub ListUnits {
552 5     5 1 1840 return sort keys %unit_by_name;
553             }
554              
555             sub ListTypes {
556 1     1 1 17 return sort keys %prototype;
557             }
558              
559             sub NumBases {
560 0     0 1 0 return $NumBases;
561             }
562              
563             sub GetTypeUnit {
564 30     30 1 20 my $t = shift;
565 30         40 return $prototype{$t};
566             }
567              
568             # DeleteNames - argument can be either an array ref, a list of name strings, or
569             # a unit object
570             sub DeleteNames {
571 4     4 1 20 my $arg0 = $_[0];
572 4   100     17 my $argIsUnit = ref $arg0 && ref $arg0 ne 'ARRAY';
573             # Get the list of names to delete
574             my $names =
575             !ref $arg0
576             ? \@_ # list of names
577             : ref $arg0 eq 'ARRAY'
578             ? $arg0 # array ref
579 4 100       12 : $arg0->{names}; # unit object
    100          
580              
581 4         6 my $u;
582 4 100       5 if ($argIsUnit) { $u = $arg0; }
  1         2  
583 4         6 for my $n (@$names) {
584 8 50       10 if (LookName($n) != 2) {
585 0         0 croak "'$n' is not a unit name.";
586             }
587 8 50       11 print "deleting '$n'\n" if $debug;
588 8         9 delete $prefix{$n};
589 8 100       10 if (!$argIsUnit) { $u = $unit_by_name{$n}; }
  5         5  
590 8         8 delete $unit_by_name{$n};
591             # Delete the array element matching $n from @{$u->{names}}
592 8 100       11 if (!$argIsUnit) {
593 5         1 $u->{names} = [ grep { $_ ne $n } @{$u->{names}} ];
  15         24  
  5         8  
594             }
595             }
596 4 100       10 if ($argIsUnit) { $u->{names} = []; }
  1         3  
597             }
598              
599              
600             sub new {
601 20     20 1 623 my $proto = shift;
602 20         50 my $class;
603              
604             my $self;
605 20 100       36 if (ref $proto) { # object method
606 2         5 $self = $proto->copy;
607             }
608             else { # class method
609 18         22 my $r = shift;
610 18         30 $self = CreateUnit($r);
611             }
612              
613 20         43 $self->AddNames(@_);
614 20         59 return $self;
615             }
616              
617             sub type {
618 49     49 1 505 my $self = shift;
619              
620             # See if the user is setting the type
621 49         31 my $t;
622 49 100       77 if ($t = shift) {
623             # XXX Maybe we should check that $t is a valid type name, and
624             # XXX that it's type really does match.
625 23         27 return $self->{type} = $t;
626             }
627              
628             # If the type is known already, return it
629 26 100       60 return $self->{type} if $self->{type};
630              
631             # See if it is a prefix
632 22         33 my $name = $self->name();
633              
634             return $self->{type} = 'prefix'
635 22 50 66     53 if defined $name && defined $prefix{$name};
636              
637             # Collect all matching types
638 22         17 my @t;
639 22         122 for (keys %prototype) {
640             push @t, $_
641 667 100       711 unless CompareDim($self, $prototype{$_});
642             }
643              
644             # Return value depends on whether we got zero, one, or multiple types
645 22 100       82 return undef unless @t;
646 18 100       295 return $self->{type} = $t[0] if @t == 1;
647 1         3 return \@t;
648             }
649              
650             sub name {
651 90     90 1 92 my $self = shift;
652 90         74 my $n = $self->{names};
653 90         195 return $$n[0];
654             }
655              
656             sub abbr {
657 19     19 1 12 my $self = shift;
658 19         15 my $n = ${$self->{names}}[0];
  19         22  
659 19 50       32 return undef unless defined $n;
660              
661 19         21 for ($self->names()) {
662 79 100       105 $n = $_ if length $_ < length $n;
663             }
664 19         31 return $n;
665             }
666              
667             sub names {
668 22     22 1 960 my $self = shift;
669 22         16 return @{$self->{names}};
  22         49  
670             }
671              
672             sub def {
673 4     4 1 5 my $self = shift;
674 4         16 return $self->{def};
675             }
676              
677             sub expanded {
678 11     11 1 21 my $self = shift;
679 11         16 my $s = $self->{factor};
680 11 100       26 $s = '' if $s == 1;
681              
682 11         10 my $i = 0;
683 11         12 for my $d (@{$self->{dim}}) {
  11         24  
684 118 100       128 if ($d) {
685             #print "Dimension index $i is $d\n";
686 22 100       29 if ($s) { $s .= " "; }
  20         58  
687 22         28 $s .= $BaseName[$i];
688 22 100       41 $s .= "^$d" unless $d == 1;
689             }
690 118         79 $i++;
691             }
692              
693 11 50       24 $s = 1 if $s eq '';
694 11         49 return $s;
695             }
696              
697             sub ToString {
698 11     11 1 6 my $self = shift;
699 11   66     23 return $self->name || $self->def || $self->expanded;
700             }
701              
702             sub factor {
703 9     9 1 12 my $self = shift;
704 9 100       21 if (@_) {
705 3         6 $self->CheckChange;
706 3         6 $self->{factor} = shift;
707             }
708 9         24 return $self->{factor};
709             }
710              
711             sub convert {
712 19     19 1 24 my ($self, $other) = @_;
713 19         24 my $u = GetUnit($other);
714 19 50       29 carp "Can't convert ". $self->name() .' to '. $u->name()
715             if CompareDim($self, $u);
716 19         68 return $self->{factor} / $u->{factor};
717             }
718              
719             sub times {
720 472     472 1 330 my $self = shift;
721 472         489 $self->CheckChange;
722 472         440 my $u = GetUnit(shift);
723 472         560 $self->{factor} *= $u->{factor};
724              
725 472         638 for (0 .. $NumBases) {
726 4756 100       4770 my $u_val = defined $u->{dim}[$_] ? $u->{dim}[$_] : 0;
727 4756 100       4300 if (defined $self->{dim}[$_]) {
728 4738         3702 $self->{dim}[$_] += $u_val;
729             }
730             else {
731 18         36 $self->{dim}[$_] = $u_val;
732             }
733             }
734              
735 472         358 $self->{type} = '';
736 472         894 return $self;
737             }
738              
739             sub recip {
740 141     141 1 91 my $self = shift;
741 141         151 $self->CheckChange;
742 141         173 $self->{factor} = 1 / $self->{factor};
743              
744 141         187 for (0 .. $NumBases) {
745 1424 100       1364 if (defined $self->{dim}[$_]) {
746 1416         1210 $self->{dim}->[$_] = -$self->{dim}->[$_];
747             }
748             else {
749 8         16 $self->{dim}[$_] = 0;
750             }
751             }
752              
753 141         203 return $self;
754             }
755              
756             sub divide {
757 139     139 1 139 my ($self, $other) = @_;
758 139         145 my $u = GetUnit($other)->copy;
759 139         182 $self->times($u->recip);
760             }
761              
762             sub power {
763 88     88 1 71 my $self = shift;
764 88         102 $self->CheckChange;
765 88         65 my $p = shift;
766 88 50       131 die 'Exponentiation to integer values only, please'
767             unless $p == int $p;
768 88         126 $self->{factor} **= $p;
769              
770 88         122 for (0 .. $NumBases) {
771 885 100       969 $self->{dim}[$_] = 0 unless defined $self->{dim}[$_];
772 885         665 $self->{dim}[$_] *= $p;
773             }
774              
775 88         75 $self->{type} = '';
776 88         64 return $self;
777             }
778              
779             sub add {
780 0     0 1 0 my $self = shift;
781 0         0 $self->CheckChange;
782              
783 0         0 my $other = shift;
784 0         0 my $u = GetUnit($other);
785              
786 0 0       0 croak "Can't add ". $u->type .' to a '. $self->type
787             if CompareDim($self, $u);
788 0         0 $self->{factor} += $u->{factor};
789 0         0 return $self;
790             }
791              
792             sub neg {
793 0     0 1 0 my $self = shift;
794 0         0 $self->CheckChange;
795 0         0 $self->{factor} = -$self->{factor};
796 0         0 return $self;
797             }
798              
799             sub subtract {
800 0     0 1 0 my ($self, $other) = @_;
801 0         0 my $u = GetUnit($other)->copy;
802 0         0 $self->add( $u->neg );
803             }
804              
805             sub copy {
806 758     758 1 554 my $self = shift;
807             my $n = {
808             'factor' => $self->{factor},
809 758         2709 'dim' => [@{$self->{dim}}],
810             'type' => $self->{type},
811             'names' => [],
812             'def' => $self->{def},
813 758         623 };
814              
815 758         757 bless $n, 'Physics::Unit';
816 758         687 return $n;
817             }
818              
819             sub equal {
820 6     6 1 9 my $obj1 = shift;
821              
822             # If it was called as a class method, throw away the first
823             # argument (the class name)
824 6 100       14 $obj1 = shift unless ref $obj1;
825 6         7 $obj1 = GetUnit($obj1);
826 6         8 my $obj2 = GetUnit(shift);
827              
828 6 50       9 return 0 if CompareDim($obj1, $obj2);
829 6 50       15 return 0 unless $obj1->{factor} == $obj2->{factor};
830 6         19 return 1;
831             }
832              
833             sub NewOne {
834 417     417 0 1262 my $u = {
835             'factor' => 1,
836             'dim' => [0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
837             'type' => undef,
838             'names' => [],
839             'def' => undef,
840             };
841 417         535 bless $u, 'Physics::Unit';
842             }
843              
844             sub AddNames {
845 539     539 0 379 my $self = shift;
846 539         357 my $n;
847 539         740 while ($n = shift) {
848 1072 50       1150 croak "Can't use a reference as a name!" if ref $n;
849 1072 50       927 carp "Name $n is already defined" if LookName($n);
850 1072         660 push @{$self->{names}}, "\L$n";
  1072         1538  
851 1072         4187 $unit_by_name{$n} = $self;
852             }
853             }
854              
855             sub NewType {
856 62     62 0 77 my ($self, $t) = @_;
857             # my $oldtype = $self->type;
858             # croak "NewType: the type $t is already defined as $oldtype"
859             # if $oldtype ne 'unknown';
860 62         57 $self->{type} = $t;
861 62         159 $prototype{$t} = $self;
862             }
863              
864             sub CreateUnit {
865 485     485 0 365 my $def = shift;
866             # argument was a Unit object
867 485 100       573 return $def->new() if ref $def;
868             # argument was either a simple name or an expression - doesn't matter
869 484         478 $def = lc $def;
870              
871 484         461 my $u = expr($def);
872 484         447 $u->{def} = $def;
873 484         463 return $u;
874             }
875              
876             sub CompareDim {
877 692     692 0 531 my ($u1, $u2) = @_;
878 692         513 my $d1 = $u1->{dim};
879 692         581 my $d2 = $u2->{dim};
880              
881 692         710 for (0 .. $NumBases) {
882 1370 100       1717 $$d1[$_] = 0 unless defined $$d1[$_];
883 1370 100       1599 $$d2[$_] = 0 unless defined $$d2[$_];
884 1370         979 my $c = ($$d1[$_] <=> $$d2[$_]);
885 1370 100       2411 return $c if $c;
886             }
887 44         101 return 0;
888             }
889              
890             sub LookName {
891 1715     1715 0 1710 my $name = shift;
892 1715 50       2125 return 3 if defined $prototype{$name};
893 1715 100       2414 return 2 if defined $unit_by_name{$name};
894 1158 100       1375 return 1 if defined $reserved_word{$name};
895 1138         1381 return 0;
896             }
897              
898             sub DebugString {
899 0     0 0 0 my $self = shift;
900 0         0 my $s = $self->{factor};
901 0         0 $s .= '['. join (', ', @{$self->{dim}}) .']';
  0         0  
902 0         0 return $s;
903             }
904              
905             sub CheckChange {
906 704     704 0 507 my $self = shift;
907 704 50       919 carp "You're not allowed to change named units!" if $self->{names}[0];
908 704         690 $self->{names} = [];
909 704         758 $self->{type} = $self->{def} = undef;
910             }
911              
912             # global variables used for parsing.
913             my $def; # string being parsed
914             my $tok; # the token type
915             my $numval; # the value when the token is a number
916             my $tokname; # when it is a name
917             my $indent; # used to indent debug messages
918              
919             # parser
920             sub expr {
921 486 100   486 0 625 if (@_) {
922 484         335 $def = shift;
923 484         525 get_token();
924             }
925              
926 486 50       684 print ' ' x $indent, "inside expr\n" if $debug;
927 486         350 $indent++;
928 486         497 my $u = term();
929              
930 486         362 for (;;) {
931 625 100       823 if ($tok eq 'times') {
    100          
932 3         4 get_token();
933 3         10 $u->times(term());
934             }
935             elsif ($tok eq 'divide') {
936 136         147 get_token();
937 136         154 $u->divide(term());
938             }
939             else {
940 486 50       543 print ' ' x $indent, "expr: returning ", $u->DebugString, "\n"
941             if $debug;
942 486         295 $indent--;
943 486         435 return $u;
944             }
945             }
946             }
947              
948             sub term {
949 625 50   625 0 727 print ' ' x $indent, "inside term\n" if $debug;
950 625         393 $indent++;
951 625         561 my $u = Factor();
952              
953 625         391 for (;;) {
954 889 50       1019 print ' ' x $indent, "inside term loop\n" if $debug;
955 889 100 66     4730 if ($tok eq 'number' ||
      100        
      100        
      66        
956             $tok eq 'name' ||
957             $tok eq 'prefix' ||
958             $tok eq 'square' ||
959             $tok eq 'cubic')
960             {
961 264         277 $u->times(Factor());
962             }
963             else {
964 625 50       710 print ' ' x $indent, "term: returning ", $u->DebugString, "\n"
965             if $debug;
966 625         364 $indent--;
967 625         669 return $u;
968             }
969             }
970             }
971              
972             sub Factor {
973 889 50   889 0 972 print ' ' x $indent, "inside factor\n" if $debug;
974 889         547 $indent++;
975              
976 889         809 my $u = prim();
977              
978 889         596 for (;;) {
979 966 50       1069 print ' ' x $indent, "inside factor loop\n" if $debug;
980 966 100       897 if ($tok eq 'exponent') {
981 77         79 get_token();
982 77 50       117 die 'Exponent must be an integer'
983             unless $tok eq 'number';
984 77         115 $u->power($numval);
985 77         98 get_token();
986             }
987             else {
988 889 50       1054 print ' ' x $indent, "factor: returning ",
989             $u->DebugString, "\n" if $debug;
990 889         535 $indent--;
991 889         949 return $u;
992             }
993             }
994             }
995              
996             sub prim {
997 963 50   963 0 1065 print ' ' x $indent, "inside prim\n" if $debug;
998 963         578 $indent++;
999              
1000 963         573 my $u;
1001              
1002 963 100       1418 if ($tok eq 'number') {
    100          
    100          
    100          
    50          
    100          
    50          
1003 338 50       382 print ' ' x $indent, "got number $numval\n" if $debug;
1004             # Create a new Unit object to represent this number
1005 338         323 $u = NewOne();
1006 338         363 $u->{factor} = $numval;
1007 338         335 get_token();
1008             }
1009             elsif ($tok eq 'prefix') {
1010 64 50       84 print ' ' x $indent, "got a prefix: ", "$tokname\n" if $debug;
1011 64         67 $u = GetUnit($tokname)->copy();
1012 64         71 get_token();
1013 64         95 $u->times(prim());
1014             }
1015             elsif ($tok eq 'name') {
1016 549 50       600 print ' ' x $indent, "got a name: ", "$tokname\n" if $debug;
1017 549         539 $u = GetUnit($tokname)->copy();
1018 549         574 get_token();
1019             }
1020             elsif ($tok eq 'lparen') {
1021 2 50       7 print ' ' x $indent, "got a left paren\n" if $debug;
1022 2         4 get_token();
1023 2         11 $u = expr();
1024 2 50       7 die 'Missing right parenthesis'
1025             unless $tok eq 'rparen';
1026 2         4 get_token();
1027             }
1028             elsif ($tok eq 'end') {
1029 0 0       0 print ' ' x $indent, "got end\n" if $debug;
1030 0         0 $u = NewOne();
1031             }
1032             elsif ($tok eq 'square') {
1033 8         9 get_token();
1034 8         15 $u = prim()->power(2);
1035             }
1036             elsif ($tok eq 'cubic') {
1037 2         5 get_token();
1038 2         5 $u = prim()->power(3);
1039             }
1040             else {
1041 0         0 die 'Primary expected';
1042             }
1043              
1044 963 50       1210 print ' ' x $indent, "prim: returning ", $u->DebugString, "\n"
1045             if $debug;
1046 963         603 $indent--;
1047              
1048             # Before returning, see if the *next* token is 'squared' or 'cubed'
1049 963         629 for(;;) {
1050 964 100       1242 if ($tok eq 'squared') {
    50          
1051 1         3 get_token();
1052 1         2 $u->power(2);
1053             }
1054             elsif ($tok eq 'cubed') {
1055 0         0 get_token();
1056 0         0 $u->power(3);
1057             }
1058             else {
1059 963         701 last;
1060             }
1061             }
1062              
1063 963         893 return $u;
1064             }
1065              
1066             sub get_token {
1067 1743 50   1743 0 2001 print ' ' x $indent, "get_token, looking at '$def'\n" if $debug;
1068              
1069             # First remove whitespace at the begining
1070 1743         2273 $def =~ s/^\s+//;
1071              
1072 1743 100       2189 if ($def eq '') {
1073 484         347 $tok = 'end';
1074 484         400 return;
1075             }
1076              
1077 1259 100 100     9083 if ($def =~ s/^\(//) {
    100          
    100          
    100          
    100          
    100          
    50          
1078 2         4 $tok = 'lparen';
1079             }
1080             elsif ($def =~ s/^\)//) {
1081 2         3 $tok = 'rparen';
1082             }
1083             elsif ($def =~ s/^\*\*// || $def =~ s/^\^//) {
1084 77         88 $tok = 'exponent';
1085             }
1086             elsif ($def =~ s/^\*//) {
1087 3         6 $tok = 'times';
1088             }
1089             elsif ($def =~ s/^\///) {
1090 127         136 $tok = 'divide';
1091             }
1092             elsif ($def =~ s/^$number_re//io) {
1093 415         793 $numval = $1 + 0; # convert to a number
1094 415         421 $tok = 'number';
1095             }
1096             elsif ($def =~ /^([^\ \n\r\t\f\(\)\/\^\*]+)/) {
1097 633         773 my $t = $1;
1098 633         633 my $l = LookName($t);
1099              
1100 633 100       1045 if ($l == 1) {
    100          
1101 20         23 $tok = $reserved_word{$t};
1102 20         17 $tokname = $t;
1103 20         25 $def = substr $def, length($t);
1104 20         41 return;
1105             }
1106             elsif ($l == 2) {
1107 549         369 $tok = 'name';
1108 549         388 $tokname = $t;
1109 549         595 $def = substr $def, length($t);
1110 549         465 return;
1111             }
1112              
1113             # Couldn't find the name on the first try, look for prefix
1114 64         288 for my $p (keys %prefix) {
1115 939 100       3688 if ($t =~ /^$p/i) {
1116 64         59 $tok = 'prefix';
1117 64         51 $tokname = $p;
1118 64         75 $def = substr $def, length($p);
1119 64         93 return;
1120             }
1121             }
1122 0           die "Unknown unit: $t\n";
1123             }
1124             else {
1125 0           die "Illegal token in $def";
1126             }
1127             }
1128              
1129             1;
1130             __END__