t/lib/TestBuilder.pm

   1 package t::lib::TestBuilder;
   2
   3 use Modern::Perl;
   4
   5 use Koha::Database;
   6 use C4::Biblio;
   7 use C4::Items;
   8 use Koha::Biblios;
   9 use Koha::Items;
  10 use Koha::DateUtils qw( dt_from_string );
  11
  12 use Bytes::Random::Secure;
  13 use Carp;
  14 use Module::Load;
  15 use String::Random;
  16
  17 use constant {
  18     SIZE_BARCODE => 20, # Not perfect but avoid to fetch the value when creating a new item
  19 };
  20
  21 sub new {
  22     my ($class) = @_;
  23     my $self = {};
  24     bless( $self, $class );
  25
  26     $self->schema( Koha::Database->new()->schema );
  27     $self->schema->storage->sql_maker->quote_char('`');
  28
  29     $self->{gen_type} = _gen_type();
  30     $self->{default_values} = _gen_default_values();
  31     return $self;
  32 }
  33
  34 sub schema {
  35     my ($self, $schema) = @_;
  36
  37     if( defined( $schema ) ) {
  38         $self->{schema} = $schema;
  39     }
  40     return $self->{schema};
  41 }
  42
  43 # sub clear has been obsoleted; use delete_all from the schema resultset
  44
  45 sub delete {
  46     my ( $self, $params ) = @_;
  47     my $source = $params->{source} || return;
  48     my @recs = ref( $params->{records} ) eq 'ARRAY'?
  49         @{$params->{records}}: ( $params->{records} // () );
  50     # tables without PK are not supported
  51     my @pk = $self->schema->source( $source )->primary_columns;
  52     return if !@pk;
  53     my $rv = 0;
  54     foreach my $rec ( @recs ) {
  55     # delete only works when you supply full primary key values
  56     # $cond does not include searches for undef (not allowed in PK)
  57         my $cond = { map { defined $rec->{$_}? ($_, $rec->{$_}): (); } @pk };
  58         next if keys %$cond < @pk;
  59         $self->schema->resultset( $source )->search( $cond )->delete;
  60         # we clear the pk columns in the supplied hash
  61         # this indirectly signals at least an attempt to delete
  62         map { delete $rec->{$_}; } @pk;
  63         $rv++;
  64     }
  65     return $rv;
  66 }
  67
  68 sub build_object {
  69     my ( $self, $params ) = @_;
  70
  71     my $class = $params->{class};
  72     my $value = $params->{value};
  73
  74     if ( not defined $class ) {
  75         carp "Missing class param";
  76         return;
  77     }
  78
  79     my @unknowns = grep( !/^(class|value)$/, keys %{ $params });
  80     carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
  81
  82     load $class;
  83     my $source = $class->_type;
  84
  85     my $hashref = $self->build({ source => $source, value => $value });
  86     my $object;
  87     if ( $class eq 'Koha::Old::Patrons' ) {
  88         $object = $class->search({ borrowernumber => $hashref->{borrowernumber} })->next;
  89     } elsif ( $class eq 'Koha::Statistics' ) {
  90         $object = $class->search({ datetime => $hashref->{datetime} })->next;
  91     } else {
  92         my @ids;
  93         my @pks = $self->schema->source( $class->_type )->primary_columns;
  94         foreach my $pk ( @pks ) {
  95             push @ids, $hashref->{ $pk };
  96         }
  97
  98         $object = $class->find( @ids );
  99     }
 100
 101     return $object;
 102 }
 103
 104 sub build {
 105 # build returns a hash of column values for a created record, or undef
 106 # build does NOT update a record, or pass back values of an existing record
 107     my ($self, $params) = @_;
 108     my $source  = $params->{source};
 109     if( !$source ) {
 110         carp "Source parameter not specified!";
 111         return;
 112     }
 113     my $value   = $params->{value};
 114
 115     my @unknowns = grep( !/^(source|value)$/, keys %{ $params });
 116     carp "Unknown parameter(s): ", join( ', ', @unknowns ) if scalar @unknowns;
 117
 118     my $col_values = $self->_buildColumnValues({
 119         source  => $source,
 120         value   => $value,
 121     });
 122     return if !$col_values; # did not meet unique constraints?
 123
 124     # loop thru all fk and create linked records if needed
 125     # fills remaining entries in $col_values
 126     my $foreign_keys = $self->_getForeignKeys( { source => $source } );
 127     for my $fk ( @$foreign_keys ) {
 128         # skip when FK points to itself: e.g. borrowers:guarantorid
 129         next if $fk->{source} eq $source;
 130         my $keys = $fk->{keys};
 131         my $tbl = $fk->{source};
 132         my $res = $self->_create_links( $tbl, $keys, $col_values, $value );
 133         return if !$res; # failed: no need to go further
 134         foreach( keys %$res ) { # save new values
 135             $col_values->{$_} = $res->{$_};
 136         }
 137     }
 138
 139     # store this record and return hashref
 140     return $self->_storeColumnValues({
 141         source => $source,
 142         values => $col_values,
 143     });
 144 }
 145
 146 sub build_sample_biblio {
 147     my ( $self, $args ) = @_;
 148
 149     my $title  = $args->{title}  || 'Some boring read';
 150     my $author = $args->{author} || 'Some boring author';
 151     my $frameworkcode = $args->{frameworkcode} || '';
 152     my $itemtype = $args->{itemtype}
 153       || $self->build_object( { class => 'Koha::ItemTypes' } )->itemtype;
 154
 155     my $marcflavour = C4::Context->preference('marcflavour');
 156
 157     my $record = MARC::Record->new();
 158     my ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'a' ) : ( 245, 'a' );
 159     $record->append_fields(
 160         MARC::Field->new( $tag, ' ', ' ', $subfield => $title ),
 161     );
 162
 163     ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 200, 'f' ) : ( 100, 'a' );
 164     $record->append_fields(
 165         MARC::Field->new( $tag, ' ', ' ', $subfield => $author ),
 166     );
 167
 168     ( $tag, $subfield ) = $marcflavour eq 'UNIMARC' ? ( 995, 'r' ) : ( 942, 'c' );
 169     $record->append_fields(
 170         MARC::Field->new( $tag, ' ', ' ', $subfield => $itemtype )
 171     );
 172
 173     my ($biblio_id) = C4::Biblio::AddBiblio( $record, $frameworkcode );
 174     return Koha::Biblios->find($biblio_id);
 175 }
 176
 177 sub build_sample_item {
 178     my ( $self, $args ) = @_;
 179
 180     my $biblionumber =
 181       delete $args->{biblionumber} || $self->build_sample_biblio->biblionumber;
 182     my $library = delete $args->{library}
 183       || $self->build_object( { class => 'Koha::Libraries' } )->branchcode;
 184
 185     # If itype is not passed it will be picked from the biblio (see Koha::Item->store)
 186
 187     my $barcode = delete $args->{barcode}
 188       || $self->_gen_text( { info => { size => SIZE_BARCODE } } );
 189
 190     my ( undef, undef, $itemnumber ) = C4::Items::AddItem(
 191         {
 192             homebranch    => $library,
 193             holdingbranch => $library,
 194             barcode       => $barcode,
 195             %$args,
 196         },
 197         $biblionumber
 198     );
 199     return Koha::Items->find($itemnumber);
 200 }
 201
 202 # ------------------------------------------------------------------------------
 203 # Internal helper routines
 204
 205 sub _create_links {
 206 # returns undef for failure to create linked records
 207 # otherwise returns hashref containing new column values for parent record
 208     my ( $self, $linked_tbl, $keys, $col_values, $value ) = @_;
 209
 210     my $fk_value = {};
 211     my ( $cnt_scalar, $cnt_null ) = ( 0, 0 );
 212
 213     # First, collect all values for creating a linked record (if needed)
 214     foreach my $fk ( @$keys ) {
 215         my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
 216         if( ref( $value->{$col} ) eq 'HASH' ) {
 217             # add all keys from the FK hash
 218             $fk_value = { %{ $value->{$col} }, %$fk_value };
 219         }
 220         if( exists $col_values->{$col} ) {
 221             # add specific value (this does not necessarily exclude some
 222             # values from the hash in the preceding if)
 223             $fk_value->{ $destcol } = $col_values->{ $col };
 224             $cnt_scalar++;
 225             $cnt_null++ if !defined( $col_values->{$col} );
 226         }
 227     }
 228
 229     # If we saw all FK columns, first run the following checks
 230     if( $cnt_scalar == @$keys ) {
 231         # if one or more fk cols are null, the FK constraint will not be forced
 232         return {} if $cnt_null > 0;
 233         # does the record exist already?
 234         return {} if $self->schema->resultset($linked_tbl)->find( $fk_value );
 235     }
 236     # create record with a recursive build call
 237     my $row = $self->build({ source => $linked_tbl, value => $fk_value });
 238     return if !$row; # failure
 239
 240     # Finally, only return the new values
 241     my $rv = {};
 242     foreach my $fk ( @$keys ) {
 243         my ( $col, $destcol ) = ( $fk->{col_name}, $fk->{col_fk_name} );
 244         next if exists $col_values->{ $col };
 245         $rv->{ $col } = $row->{ $destcol };
 246     }
 247     return $rv; # success
 248 }
 249
 250 sub _formatSource {
 251     my ($params) = @_;
 252     my $source = $params->{source} || return;
 253     $source =~ s|(\w+)$|$1|;
 254     return $source;
 255 }
 256
 257 sub _buildColumnValues {
 258     my ($self, $params) = @_;
 259     my $source = _formatSource( $params ) || return;
 260     my $original_value = $params->{value};
 261
 262     my $col_values = {};
 263     my @columns = $self->schema->source($source)->columns;
 264     my %unique_constraints = $self->schema->source($source)->unique_constraints();
 265
 266     my $build_value = 5;
 267     # we try max $build_value times if there are unique constraints
 268     BUILD_VALUE: while ( $build_value ) {
 269         # generate random values for all columns
 270         for my $col_name( @columns ) {
 271             my $valref = $self->_buildColumnValue({
 272                 source      => $source,
 273                 column_name => $col_name,
 274                 value       => $original_value,
 275             });
 276             return if !$valref; # failure
 277             if( @$valref ) { # could be empty
 278                 # there will be only one value, but it could be undef
 279                 $col_values->{$col_name} = $valref->[0];
 280             }
 281         }
 282
 283         # verify the data would respect each unique constraint
 284         # note that this is INCOMPLETE since not all col_values are filled
 285         CONSTRAINTS: foreach my $constraint (keys %unique_constraints) {
 286
 287                 my $condition;
 288                 my $constraint_columns = $unique_constraints{$constraint};
 289                 # loop through all constraint columns and build the condition
 290                 foreach my $constraint_column ( @$constraint_columns ) {
 291                     # build the filter
 292                     # if one column does not exist or is undef, skip it
 293                     # an insert with a null will not trigger the constraint
 294                     next CONSTRAINTS
 295                         if !exists $col_values->{ $constraint_column } ||
 296                         !defined $col_values->{ $constraint_column };
 297                     $condition->{ $constraint_column } =
 298                             $col_values->{ $constraint_column };
 299                 }
 300                 my $count = $self->schema
 301                                  ->resultset( $source )
 302                                  ->search( $condition )
 303                                  ->count();
 304                 if ( $count > 0 ) {
 305                     # no point checking more stuff, exit the loop
 306                     $build_value--;
 307                     next BUILD_VALUE;
 308                 }
 309         }
 310         last; # you passed all tests
 311     }
 312     return $col_values if $build_value > 0;
 313
 314     # if you get here, we have a problem
 315     warn "Violation of unique constraint in $source";
 316     return;
 317 }
 318
 319 sub _getForeignKeys {
 320
 321 # Returns the following arrayref
 322 #   [ [ source => name, keys => [ col_name => A, col_fk_name => B ] ], ... ]
 323 # The array gives source name and keys for each FK constraint
 324
 325     my ($self, $params) = @_;
 326     my $source = $self->schema->source( $params->{source} );
 327
 328     my ( @foreign_keys, $check_dupl );
 329     my @relationships = $source->relationships;
 330     for my $rel_name( @relationships ) {
 331         my $rel_info = $source->relationship_info($rel_name);
 332         if( $rel_info->{attrs}->{is_foreign_key_constraint} ) {
 333             $rel_info->{source} =~ s/^.*:://g;
 334             my $rel = { source => $rel_info->{source} };
 335
 336             my @keys;
 337             while( my ($col_fk_name, $col_name) = each(%{$rel_info->{cond}}) ) {
 338                 $col_name    =~ s|self.(\w+)|$1|;
 339                 $col_fk_name =~ s|foreign.(\w+)|$1|;
 340                 push @keys, {
 341                     col_name    => $col_name,
 342                     col_fk_name => $col_fk_name,
 343                 };
 344             }
 345             # check if the combination table and keys is unique
 346             # so skip double belongs_to relations (as in Biblioitem)
 347             my $tag = $rel->{source}. ':'.
 348                 join ',', sort map { $_->{col_name} } @keys;
 349             next if $check_dupl->{$tag};
 350             $check_dupl->{$tag} = 1;
 351             $rel->{keys} = \@keys;
 352             push @foreign_keys, $rel;
 353         }
 354     }
 355     return \@foreign_keys;
 356 }
 357
 358 sub _storeColumnValues {
 359     my ($self, $params) = @_;
 360     my $source      = $params->{source};
 361     my $col_values  = $params->{values};
 362     my $new_row = $self->schema->resultset( $source )->create( $col_values );
 363     return $new_row? { $new_row->get_columns }: {};
 364 }
 365
 366 sub _buildColumnValue {
 367 # returns an arrayref if all goes well
 368 # an empty arrayref typically means: auto_incr column or fk column
 369 # undef means failure
 370     my ($self, $params) = @_;
 371     my $source    = $params->{source};
 372     my $value     = $params->{value};
 373     my $col_name  = $params->{column_name};
 374
 375     my $col_info  = $self->schema->source($source)->column_info($col_name);
 376
 377     my $retvalue = [];
 378     if( $col_info->{is_auto_increment} ) {
 379         if( exists $value->{$col_name} ) {
 380             warn "Value not allowed for auto_incr $col_name in $source";
 381             return;
 382         }
 383         # otherwise: no need to assign a value
 384     } elsif( $col_info->{is_foreign_key} || _should_be_fk($source,$col_name) ) {
 385         if( exists $value->{$col_name} ) {
 386             if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
 387                 # This explicit undef is not allowed
 388                 warn "Null value for $col_name in $source not allowed";
 389                 return;
 390             }
 391             if( ref( $value->{$col_name} ) ne 'HASH' ) {
 392                 push @$retvalue, $value->{$col_name};
 393             }
 394             # sub build will handle a passed hash value later on
 395         }
 396     } elsif( ref( $value->{$col_name} ) eq 'HASH' ) {
 397         # this is not allowed for a column that is not a FK
 398         warn "Hash not allowed for $col_name in $source";
 399         return;
 400     } elsif( exists $value->{$col_name} ) {
 401         if( !defined $value->{$col_name} && !$col_info->{is_nullable} ) {
 402             # This explicit undef is not allowed
 403             warn "Null value for $col_name in $source not allowed";
 404             return;
 405         }
 406         push @$retvalue, $value->{$col_name};
 407     } elsif( exists $self->{default_values}{$source}{$col_name} ) {
 408         my $v = $self->{default_values}{$source}{$col_name};
 409         $v = &$v() if ref($v) eq 'CODE';
 410         push @$retvalue, $v;
 411     } else {
 412         my $data_type = $col_info->{data_type};
 413         $data_type =~ s| |_|;
 414         if( my $hdlr = $self->{gen_type}->{$data_type} ) {
 415             push @$retvalue, &$hdlr( $self, { info => $col_info } );
 416         } else {
 417             warn "Unknown type $data_type for $col_name in $source";
 418             return;
 419         }
 420     }
 421     return $retvalue;
 422 }
 423
 424 sub _should_be_fk {
 425 # This sub is only needed for inconsistencies in the schema
 426 # A column is not marked as FK, but a belongs_to relation is defined
 427     my ( $source, $column ) = @_;
 428     my $inconsistencies = {
 429         'Item.biblionumber' => 1, #FIXME: Please remove me when I become FK
 430     };
 431     return $inconsistencies->{ "$source.$column" };
 432 }
 433
 434 sub _gen_type {
 435     return {
 436         tinyint   => \&_gen_int,
 437         smallint  => \&_gen_int,
 438         mediumint => \&_gen_int,
 439         integer   => \&_gen_int,
 440         bigint    => \&_gen_int,
 441
 442         float            => \&_gen_real,
 443         decimal          => \&_gen_real,
 444         double_precision => \&_gen_real,
 445
 446         timestamp => \&_gen_datetime,
 447         datetime  => \&_gen_datetime,
 448         date      => \&_gen_date,
 449
 450         char       => \&_gen_text,
 451         varchar    => \&_gen_text,
 452         tinytext   => \&_gen_text,
 453         text       => \&_gen_text,
 454         mediumtext => \&_gen_text,
 455         longtext   => \&_gen_text,
 456
 457         set  => \&_gen_set_enum,
 458         enum => \&_gen_set_enum,
 459
 460         tinyblob   => \&_gen_blob,
 461         mediumblob => \&_gen_blob,
 462         blob       => \&_gen_blob,
 463         longblob   => \&_gen_blob,
 464     };
 465 };
 466
 467 sub _gen_int {
 468     my ($self, $params) = @_;
 469     my $data_type = $params->{info}->{data_type};
 470
 471     my $max = 1;
 472     if( $data_type eq 'tinyint' ) {
 473         $max = 127;
 474     }
 475     elsif( $data_type eq 'smallint' ) {
 476         $max = 32767;
 477     }
 478     elsif( $data_type eq 'mediumint' ) {
 479         $max = 8388607;
 480     }
 481     elsif( $data_type eq 'integer' ) {
 482         $max = 2147483647;
 483     }
 484     elsif( $data_type eq 'bigint' ) {
 485         $max = 9223372036854775807;
 486     }
 487     return int( rand($max+1) );
 488 }
 489
 490 sub _gen_real {
 491     my ($self, $params) = @_;
 492     my $max = 10 ** 38;
 493     if( defined( $params->{info}->{size} ) ) {
 494         $max = 10 ** ($params->{info}->{size}->[0] - $params->{info}->{size}->[1]);
 495     }
 496     return sprintf("%.2f", rand($max-0.1));
 497 }
 498
 499 sub _gen_date {
 500     my ($self, $params) = @_;
 501     return $self->schema->storage->datetime_parser->format_date(dt_from_string)
 502 }
 503
 504 sub _gen_datetime {
 505     my ($self, $params) = @_;
 506     return $self->schema->storage->datetime_parser->format_datetime(dt_from_string);
 507 }
 508
 509 sub _gen_text {
 510     my ($self, $params) = @_;
 511     # From perldoc String::Random
 512     my $size = $params->{info}{size} // 10;
 513     $size -= alt_rand(0.5 * $size);
 514     my $regex = $size > 1
 515         ? '[A-Za-z][A-Za-z0-9_]{'.($size-1).'}'
 516         : '[A-Za-z]';
 517     my $random = String::Random->new( rand_gen => \&alt_rand );
 518     # rand_gen is only supported from 0.27 onward
 519     return $random->randregex($regex);
 520 }
 521
 522 sub alt_rand { #Alternative randomizer
 523     my ($max) = @_;
 524     my $random = Bytes::Random::Secure->new( NonBlocking => 1 );
 525     my $r = $random->irand / 2**32;
 526     return int( $r * $max );
 527 }
 528
 529 sub _gen_set_enum {
 530     my ($self, $params) = @_;
 531     return $params->{info}->{extra}->{list}->[0];
 532 }
 533
 534 sub _gen_blob {
 535     my ($self, $params) = @_;;
 536     return 'b';
 537 }
 538
 539 sub _gen_default_values {
 540     my ($self) = @_;
 541     return {
 542         Borrower => {
 543             login_attempts => 0,
 544             gonenoaddress  => undef,
 545             lost           => undef,
 546             debarred       => undef,
 547             borrowernotes  => '',
 548         },
 549         Item => {
 550             notforloan         => 0,
 551             itemlost           => 0,
 552             withdrawn          => 0,
 553             restricted         => 0,
 554             damaged            => 0,
 555             more_subfields_xml => undef,
 556         },
 557         Category => {
 558             enrolmentfee => 0,
 559             reservefee   => 0,
 560             # Not X, used for statistics
 561             category_type => sub { return [ qw( A C S I P ) ]->[int(rand(5))] },
 562         },
 563         Itemtype => {
 564             rentalcharge => 0,
 565             rentalcharge_daily => 0,
 566             rentalcharge_hourly => 0,
 567             defaultreplacecost => 0,
 568             processfee => 0,
 569             notforloan => 0,
 570         },
 571         Aqbookseller => {
 572             tax_rate => 0,
 573             discount => 0,
 574         },
 575         AuthHeader => {
 576             marcxml => '',
 577         },
 578         RefundLostItemFeeRules => {
 579             rule_name => 'refund',
 580         },
 581     };
 582 }
 583
 584 =head1 NAME
 585
 586 t::lib::TestBuilder.pm - Koha module to create test records
 587
 588 =head1 SYNOPSIS
 589
 590     use t::lib::TestBuilder;
 591     my $builder = t::lib::TestBuilder->new;
 592
 593     # The following call creates a patron, linked to branch CPL.
 594     # Surname is provided, other columns are randomly generated.
 595     # Branch CPL is created if it does not exist.
 596     my $patron = $builder->build({
 597         source => 'Borrower',
 598         value  => { surname => 'Jansen', branchcode => 'CPL' },
 599     });
 600
 601 =head1 DESCRIPTION
 602
 603 This module automatically creates database records for you.
 604 If needed, records for foreign keys are created too.
 605 Values will be randomly generated if not passed to TestBuilder.
 606 Note that you should wrap these actions in a transaction yourself.
 607
 608 =head1 METHODS
 609
 610 =head2 new
 611
 612     my $builder = t::lib::TestBuilder->new;
 613
 614     Constructor - Returns the object TestBuilder
 615
 616 =head2 schema
 617
 618     my $schema = $builder->schema;
 619
 620     Getter - Returns the schema of DBIx::Class
 621
 622 =head2 delete
 623
 624     $builder->delete({
 625         source => $source,
 626         records => $patron, # OR: records => [ $patron, ... ],
 627     });
 628
 629     Delete individual records, created by builder.
 630     Returns the number of delete attempts, or undef.
 631
 632 =head2 build
 633
 634     $builder->build({ source  => $source_name, value => $value });
 635
 636     Create a test record in the table, represented by $source_name.
 637     The name is required and must conform to the DBIx::Class schema.
 638     Values may be specified by the optional $value hashref. Will be
 639     randomized otherwise.
 640     If needed, TestBuilder creates linked records for foreign keys.
 641     Returns the values of the new record as a hashref, or undef if
 642     the record could not be created.
 643
 644     Note that build also supports recursive hash references inside the
 645     value hash for foreign key columns, like:
 646         value => {
 647             column1 => 'some_value',
 648             fk_col2 => {
 649                 columnA => 'another_value',
 650             }
 651         }
 652     The hash for fk_col2 here means: create a linked record with build
 653     where columnA has this value. In case of a composite FK the hashes
 654     are merged.
 655
 656     Realize that passing primary key values to build may result in undef
 657     if a record with that primary key already exists.
 658
 659 =head2 build_object
 660
 661 Given a plural Koha::Object-derived class, it creates a random element, and
 662 returns the corresponding Koha::Object.
 663
 664     my $patron = $builder->build_object({ class => 'Koha::Patrons' [, value => { ... }] });
 665
 666 =head1 AUTHOR
 667
 668 Yohann Dufour <yohann.dufour@biblibre.com>
 669
 670 Koha Development Team
 671
 672 =head1 COPYRIGHT
 673
 674 Copyright 2014 - Biblibre SARL
 675
 676 =head1 LICENSE
 677
 678 This file is part of Koha.
 679
 680 Koha is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by
 681 the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
 682
 683 Koha is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
 684
 685 You should have received a copy of the GNU General Public License along with Koha; if not, see <http://www.gnu.org/licenses>.
 686
 687 =cut
 688
 689 1;