File Coverage

blib/lib/AuthCAS.pm
Criterion Covered Total %
statement 81 206 39.3
branch 20 66 30.3
condition 16 33 48.4
subroutine 11 22 50.0
pod 16 16 100.0
total 144 343 41.9


line stmt bran cond sub pod time code
1              
2             package AuthCAS;
3              
4 2     2   27951 use strict;
  2         3  
  2         54  
5 2     2   7 use vars qw( $VERSION);
  2         3  
  2         149  
6              
7             $VERSION = '1.7';
8              
9             =encoding utf8
10              
11             =head1 NAME
12              
13             AuthCAS - Client library for JA-SIG CAS 2.0 authentication server
14              
15             =head1 VERSION
16              
17             Version 1.7
18              
19             =head1 DESCRIPTION
20              
21             AuthCAS aims at providing a Perl API to JA-SIG Central Authentication System (CAS).
22             Only a basic Perl library is provided with CAS whereas AuthCAS is a full object-oriented library.
23              
24             =head1 PREREQUISITES
25              
26             This script requires IO::Socket::SSL and LWP::UserAgent
27              
28             =head1 SYNOPSIS
29              
30             A simple example with a direct CAS authentication
31              
32             use AuthCAS;
33             my $cas = new AuthCAS(casUrl => 'https://cas.myserver,
34             CAFile => '/etc/httpd/conf/ssl.crt/ca-bundle.crt',
35             );
36              
37             my $login_url = $cas->getServerLoginURL('http://myserver/app.cgi');
38              
39             ## The user should be redirected to the $login_url
40             ## When coming back from the CAS server a ticket is provided in the QUERY_STRING
41              
42             ## $ST should contain the receaved Service Ticket
43             my $user = $cas->validateST('http://myserver/app.cgi', $ST);
44              
45             printf "User authenticated as %s\n", $user;
46              
47              
48             In the following example a proxy is requesting a Proxy Ticket for the target application
49              
50             $cas->proxyMode(pgtFile => '/tmp/pgt.txt',
51             pgtCallbackUrl => 'https://myserver/proxy.cgi?callback=1
52             );
53            
54             ## Same as before but the URL is the proxy URL
55             my $login_url = $cas->getServerLoginURL('http://myserver/proxy.cgi');
56              
57             ## Like in the previous example we should receave a $ST
58              
59             my $user = $cas->validateST('http://myserver/proxy.cgi', $ST);
60              
61             ## Process errors
62             printf STDERR "Error: %s\n", &AuthCAS::get_errors() unless (defined $user);
63              
64             ## Now we request a Proxy Ticket for the target application
65             my $PT = $cas->retrievePT('http://myserver/app.cgi');
66            
67             ## This piece of code is executed by the target application
68             ## It received a Proxy Ticket from the proxy
69             my ($user, @proxies) = $cas->validatePT('http://myserver/app.cgi', $PT);
70              
71             printf "User authenticated as %s via %s proxies\n", $user, join(',',@proxies);
72              
73              
74             =head1 DESCRIPTION
75              
76             Jasig CAS is Yale University's web authentication system, heavily inspired by Kerberos.
77             Release 2.0 of CAS provides "proxied credential" feature that allows authentication
78             tickets to be carried by intermediate applications (Portals for instance), they are
79             called proxy.
80              
81             This AuthCAS Perl module provides required subroutines to validate and retrieve CAS tickets.
82              
83             =cut
84              
85             my @ISA = qw(Exporter);
86             my @EXPORT = qw($errors);
87              
88             my $errors;
89              
90 2     2   10 use Carp;
  2         5  
  2         3809  
91              
92             =pod
93              
94             =head2 new
95              
96             my $cas = new AuthCAS(
97             casUrl => 'https://cas.myserver',
98             CAFile => '/etc/httpd/conf/ssl.crt/ca-bundle.crt',
99             );
100              
101             The C constructor lets you create a new B object.
102              
103             =over
104              
105             =item casUrl - REQUIRED
106              
107             =item CAFile
108              
109             =item CAPath
110              
111             =item loginPath - '/login'
112              
113             =item logoutPath - '/logout'
114              
115             =item serviceValidatePath - '/serviceValidate'
116              
117             =item proxyPath - '/proxy'
118              
119             =item proxyValidatePath - '/proxyValidate'
120              
121             =item SSL_version - unset
122              
123             Sets the version of the SSL protocol used to transmit data. If the default causes connection issues, setting it to 'SSLv3' may help.
124             see the documentation for L for more information
125             see L for more details.
126              
127             =back
128              
129             Returns a new B or dies on error.
130              
131             =cut
132              
133             sub new {
134 2     2 1 629 my ( $pkg, %param ) = @_;
135             my $cas_server = {
136             url => $param{'casUrl'},
137             CAFile => $param{'CAFile'},
138             CAPath => $param{'CAPath'},
139              
140             loginPath => $param{'loginPath'} || '/login',
141             logoutPath => $param{'logoutPath'} || '/logout',
142             serviceValidatePath => $param{'serviceValidatePath'}
143             || '/serviceValidate',
144             proxyPath => $param{'proxyPath'} || '/proxy',
145             proxyValidatePath => $param{'proxyValidatePath'} || '/proxyValidate',
146             SSL_version => $param{SSL_version},
147 2   50     36 };
      50        
      50        
      50        
      50        
148              
149 2         3 bless $cas_server, $pkg;
150              
151 2         5 return $cas_server;
152             }
153              
154             =pod
155              
156             =head2 get_errors
157              
158             Return module errors
159              
160             =cut
161              
162             sub get_errors {
163 0     0 1 0 return $errors;
164             }
165              
166             =pod
167              
168             =head2 proxyMode
169              
170             Use the CAS object as a proxy
171              
172              
173             =over
174              
175             =item pgtFile
176             =item pgtCallbackUrl
177              
178             =back
179              
180              
181             =cut
182              
183             sub proxyMode {
184 0     0 1 0 my $self = shift;
185 0         0 my %param = @_;
186              
187 0         0 $self->{'pgtFile'} = $param{'pgtFile'};
188 0         0 $self->{'pgtCallbackUrl'} = $param{'pgtCallbackUrl'};
189 0         0 $self->{'proxy'} = 1;
190              
191 0         0 return 1;
192             }
193              
194             ## Escape dangerous chars in URLS
195             sub _escape_chars {
196 5     5   4 my $s = shift;
197              
198             ## Escape chars
199             ## !"#$%&'()+,:;<=>?[] AND accented chars
200             ## escape % first
201             # foreach my $i (0x25,0x20..0x24,0x26..0x2c,0x3a..0x3f,0x5b,0x5d,0x80..0x9f,0xa0..0xff) {
202 5         8 foreach my $i (0x26) {
203 5         13 my $hex_i = sprintf "%lx", $i;
204 5         27 $s =~ s/\x$hex_i/%$hex_i/g;
205             }
206              
207 5         12 return $s;
208             }
209              
210             =pod
211              
212             =head2 dump_var
213              
214              
215             =cut
216              
217             sub dump_var {
218 0     0 1 0 my ( $var, $level, $fd ) = @_;
219              
220 0 0       0 if ( ref($var) ) {
221 0 0       0 if ( ref($var) eq 'ARRAY' ) {
    0          
222 0         0 foreach my $index ( 0 .. $#{$var} ) {
  0         0  
223 0         0 print $fd "\t" x $level . $index . "\n";
224 0         0 &dump_var( $var->[$index], $level + 1, $fd );
225             }
226             }
227             elsif ( ref($var) eq 'HASH' ) {
228 0         0 foreach my $key ( sort keys %{$var} ) {
  0         0  
229 0         0 print $fd "\t" x $level . '_' . $key . '_' . "\n";
230 0         0 &dump_var( $var->{$key}, $level + 1, $fd );
231             }
232             }
233             }
234             else {
235 0 0       0 if ( defined $var ) {
236 0         0 print $fd "\t" x $level . "'$var'" . "\n";
237             }
238             else {
239 0         0 print $fd "\t" x $level . "UNDEF\n";
240             }
241             }
242             }
243              
244             ## Parse an HTTP URL
245             sub _parse_url {
246 3     3   3 my $url = shift;
247              
248 3         5 my ( $host, $port, $path );
249              
250 3 50       18 if ( $url =~ /^(https?):\/\/([^:\/]+)(:(\d+))?(.*)$/ ) {
251 3         8 $host = $2;
252 3         4 $path = $5;
253 3 50       12 if ( $1 eq 'http' ) {
    50          
254 0   0     0 $port = $4 || 80;
255             }
256             elsif ( $1 eq 'https' ) {
257 3   100     13 $port = $4 || 443;
258             }
259             else {
260 0         0 $errors = sprintf "Unknown protocol '%s'\n", $1;
261 0         0 return undef;
262             }
263             }
264             else {
265 0         0 $errors = sprintf "Unable to parse URL '%s'\n", $url;
266 0         0 return undef;
267             }
268              
269 3         8 return ( $host, $port, $path );
270             }
271              
272             ## Simple XML parser
273             sub _parse_xml {
274 0     0   0 my $data = shift;
275              
276 0         0 my %xml_struct;
277              
278 0         0 while ( $data =~ /^<([^\s>]+)(\s+[^\s>]+)*>([\s\S\n]*)(<\/\1>)/m ) {
279 0         0 my ( $new_tag, $new_data ) = ( $1, $3 );
280 0         0 chomp $new_data;
281 0         0 $new_data =~ s/^[\s\n]+//m;
282 0         0 $data =~ s/^<$new_tag(\s+[^\s>]+)*>([\s\S\n]*)(<\/$new_tag>)//m;
283 0         0 $data =~ s/^[\s\n]+//m;
284              
285             ## Check if data still includes XML tags
286 0         0 my $struct;
287 0 0       0 if ( $new_data =~ /^<([^\s>]+)(\s+[^\s>]+)*>([\s\S\n]*)(<\/\1>)/m ) {
288 0         0 $struct = &_parse_xml($new_data);
289             }
290             else {
291 0         0 $struct = $new_data;
292             }
293 0         0 push @{ $xml_struct{$new_tag} }, $struct;
  0         0  
294             }
295              
296 0         0 return \%xml_struct;
297             }
298              
299             =pod
300              
301             =head2 getServerLoginURL($service)
302              
303             Returns a URL that you can redirect the browser to, which includes the URL to return to
304              
305             TODO: it escapes the return URL, but I've noticed some issues with more complicated URL's
306              
307             =cut
308              
309             sub getServerLoginURL {
310 2     2 1 9 my $self = shift;
311 2         3 my $service = shift;
312              
313             return
314             $self->{'url'}
315 2         9 . $self->{'loginPath'}
316             . '?service='
317             . &_escape_chars($service);
318             }
319              
320             =pod
321              
322             =head2 getServerLoginGatewayURL($service)
323              
324             Returns non-blocking login URL
325             ie: if user is logged in, return the ticket, otherwise do not prompt for login
326              
327             =cut
328              
329             sub getServerLoginGatewayURL {
330 0     0 1 0 my $self = shift;
331 0         0 my $service = shift;
332              
333             return
334             $self->{'url'}
335 0         0 . $self->{'loginPath'}
336             . '?service='
337             . &_escape_chars($service)
338             . '&gateway=1';
339             }
340              
341             =pod
342              
343             =head2 getServerLogoutURL($service)
344              
345             Return logout URL
346             After logout user is redirected back to the application
347              
348             =cut
349              
350             sub getServerLogoutURL {
351 0     0 1 0 my $self = shift;
352 0         0 my $service = shift;
353              
354             return
355             $self->{'url'}
356 0         0 . $self->{'logoutPath'}
357             . '?service='
358             . &_escape_chars($service)
359             . '&gateway=1';
360             }
361              
362             =pod
363              
364             =head2 getServerServiceValidateURL($service, $ticket, $pgtUrl)
365              
366             Returns
367              
368             =cut
369              
370             sub getServerServiceValidateURL {
371 3     3 1 3 my $self = shift;
372 3         3 my $service = shift;
373 3         4 my $ticket = shift;
374 3         2 my $pgtUrl = shift;
375              
376 3         7 my $query_string =
377             'service=' . &_escape_chars($service) . '&ticket=' . $ticket;
378 3 50       13 if ( defined $pgtUrl ) {
379 0         0 $query_string .= '&pgtUrl=' . &_escape_chars($pgtUrl);
380             }
381              
382             ## URL was /validate with CAS 1.0
383             return
384             $self->{'url'}
385 3         14 . $self->{'serviceValidatePath'} . '?'
386             . $query_string;
387             }
388              
389             =pod
390              
391             =head2 getServerProxyURL($targetService, $pgt)
392              
393             Returns
394              
395             =cut
396              
397             sub getServerProxyURL {
398 0     0 1 0 my $self = shift;
399 0         0 my $targetService = shift;
400 0         0 my $pgt = shift;
401              
402             return
403             $self->{'url'}
404 0         0 . $self->{'proxyPath'}
405             . '?targetService='
406             . &_escape_chars($targetService) . '&pgt='
407             . &_escape_chars($pgt);
408             }
409              
410             =pod
411              
412             =head2 getServerProxyValidateURL($service, $ticket)
413              
414             Returns
415              
416             =cut
417              
418             sub getServerProxyValidateURL {
419 0     0 1 0 my $self = shift;
420 0         0 my $service = shift;
421 0         0 my $ticket = shift;
422              
423             return
424             $self->{'url'}
425 0         0 . $self->{'proxyValidatePath'}
426             . '?service='
427             . &_escape_chars($service)
428             . '&ticket='
429             . &_escape_chars($ticket);
430              
431             }
432              
433             =pod
434              
435             =head2 validateST($service, $ticket)
436              
437             Validate a Service Ticket
438             Also used to get a PGT
439              
440              
441             Returns the login that created the ticket, if the ticket is valid for that $service URL
442              
443             returns undef if the ticket is not valid.
444              
445             =cut
446              
447             sub validateST {
448 5     5 1 14 my $self = shift;
449 5         3 my $service = shift;
450 5         7 my $ticket = shift;
451            
452 5 100       11 if (!defined($service)) {
453 1         3 $errors = 'Need a service url to validate ticket.';
454 1         6 return undef;
455             }
456 4 100       10 if (!defined($ticket)) {
457 1         2 $errors = 'No ticket to validate.';
458 1         4 return undef;
459             }
460              
461 3         4 my $pgtUrl = $self->{'pgtCallbackUrl'};
462              
463 3         8 my $xml =
464             $self->callCAS(
465             $self->getServerServiceValidateURL( $service, $ticket, $pgtUrl ) );
466              
467 3 50       19 if ( defined $xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'} )
468             {
469             $errors = sprintf "Failed to validate Service Ticket %s : %s\n",
470             $ticket,
471 0         0 $xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'}[0];
472 0         0 return undef;
473             }
474              
475             my $user =
476             $xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0]
477 3         12 {'cas:user'}[0];
478              
479             ## If in Proxy mode, also retreave a PGT
480 3 50       10 if ( $self->{'proxy'} ) {
481 0         0 my $pgtIou;
482 0 0       0 if (
483             defined $xml->{'cas:serviceResponse'}[0]
484             {'cas:authenticationSuccess'}[0]{'cas:proxyGrantingTicket'} )
485             {
486             $pgtIou =
487             $xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0]
488 0         0 {'cas:proxyGrantingTicket'}[0];
489             }
490              
491 0 0       0 unless ( defined $self->{'pgtFile'} ) {
492 0         0 $errors = sprintf "pgtFile not defined\n";
493 0         0 return undef;
494             }
495              
496             ## Check stored PGT
497 0 0       0 unless ( open STORE, $self->{'pgtFile'} ) {
498 0         0 $errors = sprintf "Unable to read %s\n", $self->{'pgtFile'};
499 0         0 return undef;
500             }
501              
502 0         0 my $pgtId;
503 0         0 while () {
504 0 0       0 if (/^$pgtIou\s+(.+)$/) {
505 0         0 $pgtId = $1;
506 0         0 last;
507             }
508             }
509              
510 0         0 $self->{'pgtId'} = $pgtId;
511             }
512              
513 3         39 return ($user);
514             }
515              
516             =pod
517              
518             =head2 validatePT($service, $ticket)
519              
520             Validate a Proxy Ticket
521              
522             Returns the login that created the ticket, if the ticket is valid for that $service URL,
523             and a list of Proxies used.
524            
525             user returned == undef if its not a valid ticket
526              
527             =cut
528              
529             sub validatePT {
530 0     0 1 0 my $self = shift;
531 0         0 my $service = shift;
532 0         0 my $ticket = shift;
533              
534 0 0       0 if (!defined($service)) {
535 0         0 $errors = 'Need a service url to validate ticket.';
536 0         0 return undef;
537             }
538 0 0       0 if (!defined($ticket)) {
539 0         0 $errors = 'No ticket to validate.';
540 0         0 return undef;
541             }
542              
543 0         0 my $xml =
544             $self->callCAS( $self->getServerProxyValidateURL( $service, $ticket ) );
545              
546 0 0       0 if ( defined $xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'} )
547             {
548             $errors = sprintf "Failed to validate Proxy Ticket %s : %s\n", $ticket,
549 0         0 $xml->{'cas:serviceResponse'}[0]{'cas:authenticationFailure'}[0];
550 0         0 return undef;
551             }
552              
553             my $user =
554             $xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0]
555 0         0 {'cas:user'}[0];
556              
557 0         0 my @proxies;
558 0 0       0 if (
559             defined $xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0]
560             {'cas:proxies'} )
561             {
562             @proxies =
563 0         0 @{ $xml->{'cas:serviceResponse'}[0]{'cas:authenticationSuccess'}[0]
564 0         0 {'cas:proxies'}[0]{'cas:proxy'} };
565             }
566              
567 0         0 return ( $user, @proxies );
568             }
569              
570             =pod
571              
572             =head2 callCAS($url)
573              
574             ## Access a CAS URL and parses received XML
575              
576             Returns
577              
578             =cut
579              
580             sub callCAS {
581 3     3 1 3 my $self = shift;
582 3         3 my $url = shift;
583              
584 3         8 my ( $host, $port, $path ) = &_parse_url($url);
585              
586             my $xml = get_https2(
587             $host, $port, $path,
588             {
589             'cafile' => $self->{'CAFile'},
590             'capath' => $self->{'CAPath'},
591 3         15 'SSL_version' => $self->{'SSL_version'}
592             }
593             );
594              
595             #use Data::Dumper; die '--'.$#$xml.': '.Dumper($xml);
596              
597 3 50 33     18 unless ($xml && $#$xml >= 0) {
598 3         339 warn $errors;
599 3         16 return undef;
600             }
601              
602             ## Skip HTTP header fields
603 0         0 my $line = shift @$xml;
604 0         0 while ( $line !~ /^\s*$/ ) {
605 0         0 $line = shift @$xml;
606             }
607              
608 0         0 return &_parse_xml( join( '', @$xml ) );
609             }
610              
611             =pod
612              
613             =head2 storePGT($pgtIou, $pgtId)
614              
615             =cut
616              
617             sub storePGT {
618 0     0 1 0 my $self = shift;
619 0         0 my $pgtIou = shift;
620 0         0 my $pgtId = shift;
621              
622 0 0       0 unless ( open STORE, ">>$self->{'pgtFile'}" ) {
623 0         0 $errors = sprintf "Unable to write to %s\n", $self->{'pgtFile'};
624 0         0 return undef;
625             }
626 0         0 printf STORE "%s\t%s\n", $pgtIou, $pgtId;
627 0         0 close STORE;
628              
629 0         0 return 1;
630             }
631              
632             =pod
633              
634             =head2 retrievePT($service)
635              
636             Returns
637              
638             =cut
639              
640             sub retrievePT {
641 0     0 1 0 my $self = shift;
642 0         0 my $service = shift;
643              
644             my $xml =
645 0         0 $self->callCAS( $self->getServerProxyURL( $service, $self->{'pgtId'} ) );
646              
647 0 0       0 if ( defined $xml->{'cas:serviceResponse'}[0]{'cas:proxyFailure'} ) {
648             $errors = sprintf "Failed to get PT : %s\n",
649 0         0 $xml->{'cas:serviceResponse'}[0]{'cas:proxyFailure'}[0];
650 0         0 return undef;
651             }
652              
653 0 0       0 if (
654             defined $xml->{'cas:serviceResponse'}[0]{'cas:proxySuccess'}[0]
655             {'cas:proxyTicket'} )
656             {
657             return $xml->{'cas:serviceResponse'}[0]{'cas:proxySuccess'}[0]
658 0         0 {'cas:proxyTicket'}[0];
659             }
660              
661 0         0 return undef;
662             }
663              
664             =pod
665              
666             =head2 get_https2
667              
668             request a document using https, return status and content
669              
670             Sven suspects this is intended to be private.
671              
672             Returns
673              
674             =cut
675              
676             sub get_https2 {
677 3     3 1 4 my $host = shift;
678 3         3 my $port = shift;
679 3         4 my $path = shift;
680              
681 3         2 my $ssl_data = shift;
682              
683 3         5 my $trusted_ca_file = $ssl_data->{'cafile'};
684 3         4 my $trusted_ca_path = $ssl_data->{'capath'};
685              
686 3 100 66     150 if ( ( $trusted_ca_file && !( -r $trusted_ca_file ) )
      33        
      66        
687             || ( $trusted_ca_path && !( -d $trusted_ca_path ) ) )
688             {
689 1   50     9 $errors = sprintf
      50        
690             "error : incorrect access to cafile ".($trusted_ca_file||'')." or capath ".($trusted_ca_path||'')."\n";
691 1         3 return undef;
692             }
693              
694 2 50       155 unless ( eval "require IO::Socket::SSL" ) {
695 0         0 $errors = sprintf
696             "Unable to use SSL library, IO::Socket::SSL required, install IO-Socket-SSL (CPAN) first\n";
697 0         0 return undef;
698             }
699 2         64667 require IO::Socket::SSL;
700              
701 2 50       74 unless ( eval "require LWP::UserAgent" ) {
702 0         0 $errors = sprintf
703             "Unable to use LWP library, LWP::UserAgent required, install LWP (CPAN) first\n";
704 0         0 return undef;
705             }
706 2         29067 require LWP::UserAgent;
707              
708 2         3 my $ssl_socket;
709              
710 2         16 my %ssl_options = (
711             SSL_use_cert => 0,
712             PeerAddr => $host,
713             PeerPort => $port,
714             Proto => 'tcp',
715             Timeout => '5'
716             );
717              
718 2 50       6 $ssl_options{'SSL_ca_file'} = $trusted_ca_file if ($trusted_ca_file);
719 2 50       7 $ssl_options{'SSL_ca_path'} = $trusted_ca_path if ($trusted_ca_path);
720              
721             ## If SSL_ca_file or SSL_ca_path => verify peer certificate
722 2 50 33     14 $ssl_options{'SSL_verify_mode'} = 0x01
723             if ( $trusted_ca_file || $trusted_ca_path );
724              
725             $ssl_options{'SSL_version'} = $ssl_data->{'SSL_version'}
726 2 50       10 if defined( $ssl_data->{'SSL_version'} );
727              
728 2         28 $ssl_socket = new IO::Socket::SSL(%ssl_options);
729              
730 2 50       17922 unless ($ssl_socket) {
731 2         13 $errors = sprintf "error %s unable to connect https://%s:%s/\n",
732             &IO::Socket::SSL::errstr, $host, $port;
733 2         43 return undef;
734             }
735              
736 0           my $request = "GET $path HTTP/1.0\r\nHost: $host\r\n\r\n";
737 0           print $ssl_socket "$request";
738              
739 0           my @result;
740 0           while ( my $line = $ssl_socket->getline ) {
741 0           push @result, $line;
742             }
743              
744 0           $ssl_socket->close( SSL_no_shutdown => 1 );
745              
746 0           return \@result;
747             }
748              
749             =pod
750              
751             =head1 SEE ALSO
752              
753             JA-SIG Central Authentication Service L
754              
755             was Yale Central Authentication Service L
756            
757             phpCAS L
758              
759             =head1 COPYRIGHT
760              
761             Copyright (C) 2003, 2005,2006,2007,2009 Olivier Salaun - Comité Réseau des Universités L
762             2012 Sven Dowideit - L
763              
764              
765             This library is free software; you can redistribute it and/or modify
766             it under the same terms as Perl itself.
767              
768             =head1 AUTHORS
769              
770             Olivier Salaun
771             Sven Dowideit
772              
773             =cut
774              
775             1;
776