1package Net::FreeDB; 2 3use Moo; 4use Net::FreeDBConnection; 5use Net::Cmd qw/CMD_OK CMD_MORE/; 6use CDDB::File; 7use File::Temp; 8 9has hostname => (is => 'ro', default => $ENV{HOSTNAME} // 'unknown'); 10has remote_host => (is => 'rw', default => 'freedb.freedb.org'); 11has remote_port => (is => 'rw', default => 8880); 12has user => (is => 'rw', default => $ENV{USER} // 'unknown'); 13has timeout => (is => 'rw', default => 120); 14has debug => (is => 'rw', default => 0); 15has current_protocol_level => (is => 'rw'); 16has max_protocol_level => (is => 'rw'); 17has obj => (is => 'rw', lazy => 1, builder => '_create_obj'); 18has error => (is => 'rw'); 19 20require DynaLoader; 21extends 'DynaLoader'; 22 23our $VERSION = '0.10'; 24bootstrap Net::FreeDB $VERSION; 25 26sub _create_obj 27{ 28 my $self = shift; 29 my $obj = Net::FreeDBConnection->new( 30 PeerAddr => $self->remote_host, 31 PeerPort => $self->remote_port, 32 Proto => 'tcp', 33 Timeout => $self->timeout, 34 ); 35 36 if ($obj) { 37 my $res = $obj->response(); 38 39 if ($res == CMD_OK) { 40 $obj->debug($self->debug); 41 if ($obj->command(join(' ', ("CDDB HELLO ", $self->user, $self->hostname, ref($self), $self->VERSION)))) { 42 my $response_code = $obj->response(); 43 if ($response_code != CMD_OK) { 44 $self->error($obj->message()); 45 } 46 } 47 } else { 48 $obj = undef; 49 } 50 } 51 52 return $obj; 53} 54 55sub lscat 56{ 57 my $self = shift; 58 my @categories = (); 59 60 if ($self->_run_command('CDDB LSCAT') == CMD_OK) { 61 my $data = $self->_read(); 62 if ($data) { 63 map { my $line = $_; chomp($line); push @categories, $line; } @$data; 64 } 65 } 66 67 return @categories; 68} 69 70sub query 71{ 72 my $self = shift; 73 my @results = (); 74 75 if ($self->_run_command('CDDB QUERY', @_) == CMD_OK) { 76 if ($self->obj->code() == 200) { 77 my $data = $self->obj->message(); 78 push @results, _query_line_to_hash($data); 79 } elsif ($self->obj->code() == 211) { 80 my $lines = $self->_read(); 81 foreach my $line (@$lines) { 82 push @results, _query_line_to_hash($line); 83 } 84 } 85 } 86 87 return @results; 88} 89 90sub read 91{ 92 my $self = shift; 93 my $result = undef; 94 95 if ($self->_run_command('CDDB READ', @_) == CMD_OK) { 96 my $data = $self->_read(); 97 my $fh = File::Temp->new(); 98 print $fh join('', @$data); 99 seek($fh, 0, 0); 100 my $cddb_file_obj = CDDB::File->new($fh->filename); 101 $fh->close; 102 $result = $cddb_file_obj; 103 } 104 105 return $result; 106} 107 108sub unlink 109{ 110 my $self = shift; 111 my $response = undef; 112 113 if ($self->_run_command('CDDB UNLINK', @_) == CMD_OK) { 114 $response = 1; 115 } 116 117 return $response; 118} 119 120sub write 121{ 122 my $self = shift; 123 my $response = undef; 124 my $category = shift; 125 my $disc_id = shift; 126 127 if ($self->_run_command('CDDB WRITE', $category, $disc_id) == CMD_MORE) { 128 if ($self->_run_command(@_, ".\n") == CMD_OK) { 129 $response = 1; 130 } 131 } 132 133 return $response; 134} 135 136sub discid 137{ 138 my $self = shift; 139 my $response = undef; 140 141 if ($self->_run_command('DISCID', @_) == CMD_OK) { 142 $response = $self->obj->message(); 143 chomp($response); 144 my (undef, undef, undef, $disc_id) = split(/\s/, $response); 145 $response = $disc_id; 146 } 147 148 return $response; 149} 150 151sub get 152{ 153 my $self = shift; 154 my $filename = shift; 155 my $file_contents = undef; 156 157 if ($self->_run_command('GET', $filename) == CMD_OK) { 158 $file_contents = $self->_read(); 159 } 160 161 return $file_contents; 162} 163 164sub log 165{ 166 my $self = shift; 167 my @log_lines = (); 168 169 if ($self->_run_command('LOG -l', @_) == CMD_OK) { 170 my $lines = $self->_read(); 171 foreach my $line (@$lines) { 172 chomp($line); 173 push @log_lines, $line; 174 } 175 } 176 177 return @log_lines; 178} 179 180sub motd 181{ 182 my $self = shift; 183 my @motd = (); 184 185 if ($self->_run_command('MOTD') == CMD_OK) { 186 push @motd, $self->obj->message(); 187 my $lines = $self->_read(); 188 foreach my $line (@$lines) { 189 chomp($line); 190 push @motd, $line; 191 } 192 } 193 194 return @motd; 195} 196 197sub proto 198{ 199 my $self = shift; 200 my ($current_level, $max_level); 201 202 if ($self->_run_command("PROTO", @_) == CMD_OK) { 203 my $message = $self->obj->message(); 204 if ($message =~ /OK/) { 205 $message =~ /OK, CDDB protocol level now: (\d)/; 206 $self->current_protocol_level($1); 207 } else { 208 $message =~ /CDDB protocol level: current (\d), supported (\d)/; 209 $self->current_protocol_level($1); 210 $self->max_protocol_level($2); 211 } 212 } 213 214 return $self->current_protocol_level(); 215} 216 217 218sub put 219{ 220 my $self = shift; 221 my $type = shift; 222 223 if ($self->_run_command('PUT', $type) == CMD_MORE) { 224 $self->obj->datasend(@_); 225 } 226} 227 228sub quit 229{ 230 my $self = shift; 231 $self->_run_command('QUIT'); 232} 233 234sub sites 235{ 236 my $self = shift; 237 my @sites = (); 238 239 if ($self->_run_command('SITES') == CMD_OK) { 240 my $lines = $self->_read(); 241 foreach my $line (@$lines) { 242 chomp($line); 243 my ($hostname, $port, $latitude, $longitude, $description) = split(/\s/, $line, 5); 244 push @sites, { 245 hostname => $hostname, 246 port => $port, 247 latitude => $latitude, 248 longitude => $longitude, 249 description => $description, 250 }; 251 } 252 } 253 254 return @sites; 255} 256 257sub stat 258{ 259 my $self = shift; 260 my $response = {}; 261 262 if ($self->_run_command('STAT') == CMD_OK) { 263 my $lines = $self->_read(); 264 foreach my $line (@$lines) { 265 chomp($line); 266 my ($key, $value) = split(/:/, $line); 267 if ($key && $value) { 268 $key =~ s/\s*(.+)\s*/$1/; 269 $value =~ s/\s*(.+)\s*/$1/; 270 $response->{$key} = $value; 271 } 272 } 273 } 274 275 return $response; 276} 277 278sub update 279{ 280 my $self = shift; 281 my $response = undef; 282 283 if ($self->_run_command('UPDATE') == CMD_OK) { 284 $response = 1; 285 } 286 287 return $response; 288} 289 290sub validate 291{ 292 my $self = shift; 293 my $response = undef; 294 295 if ($self->_run_command('VALIDATE') == CMD_MORE) { 296 if ($self->run_command(@_ . "\n") == CMD_OK) { 297 $response = 1; 298 } 299 } 300 301 return $response; 302} 303 304sub ver 305{ 306 my $self = shift; 307 my $response = undef; 308 309 if ($self->_run_command('VER') == CMD_OK) { 310 $response = $self->obj->message(); 311 } 312 313 return $response; 314} 315 316sub whom 317{ 318 my $self = shift; 319 my @users = (); 320 321 if ($self->_run_command('WHOM') == CMD_OK) { 322 my $lines = $self->_read(); 323 foreach my $line (@$lines) { 324 chomp($line); 325 push @users, $line; 326 } 327 } 328 329 return @users; 330} 331 332sub get_local_disc_id 333{ 334 my $self = shift; 335 my $device = shift; 336 my $disc_id = undef; 337 338 if ($device) { 339 $disc_id = xs_discid($device); 340 if ($disc_id eq 'UNDEF' || $disc_id eq '') { 341 $self->error('Drive Error: no disc found'); 342 $disc_id = undef; 343 } 344 } 345 346 return $disc_id; 347} 348 349sub get_local_disc_data 350{ 351 my $self = shift; 352 my $device = shift; 353 my $disc_data = undef; 354 355 if ($device) { 356 $disc_data = xs_discinfo($device); 357 if (!$disc_data) { 358 $self->error('Drive Error: no disc found'); 359 } 360 } 361 362 return $disc_data; 363} 364 365sub _read 366{ 367 my $self = shift; 368 my $data = $self->obj->read_until_dot 369 or return undef; 370 371 return $data; 372} 373 374sub _query_line_to_hash 375{ 376 my $line = shift; 377 chomp($line); 378 my ($category, $disc_id, $the_rest) = split(/\s/, $line, 3); 379 my ($artist, $album) = split(/\s\/\s/, $the_rest); 380 381 return { 382 Category => $category, 383 DiscID => $disc_id, 384 Artist => $artist, 385 Album => $album, 386 }; 387} 388 389sub _run_command 390{ 391 my ($self, @arguments) = @_; 392 393 my $response_code = undef; 394 if ($self->obj->command(@arguments)) { 395 $response_code = $self->obj->response(); 396 if ($response_code != CMD_OK) { 397 my $error = $self->obj->message(); 398 chomp($error); 399 $self->error($error); 400 } 401 } 402 403 return $response_code; 404} 405 4061; 407 408__END__ 409 410 411=head1 NAME 412 413Net::FreeDB - Perl interface to freedb server(s) 414 415=head1 SYNOPSIS 416 417 use Net::FreeDB; 418 $freedb = Net::FreeDB->new(); 419 $discdata = $freedb->getdiscdata('/dev/cdrom'); 420 my $cddb_file_object = $freedb->read('rock', $discdata->{ID}); 421 print $cddb_file_object->id; 422 423=head1 DESCRIPTION 424 425 Net::FreeDB was inspired by Net::CDDB. And in-fact 426 was designed as a replacement in-part by Net::CDDB's 427 author Jeremy D. Zawodny. Net::FreeDB allows an 428 oop interface to the freedb server(s) as well as 429 some basic cdrom functionality like determining 430 disc ids, track offsets, etc. 431 432=head2 METHODS 433 434=over 435 436=item new(remote_host => $h, remote_port => $p, user => $u, hostname => $hn, timeout => $to) 437 438 Constructor: 439 Creates a new Net::FreeDB object. 440 441 Parameters: 442 Set to username or user-string you'd like to be logged as. Defaults to $ENV{USER} 443 444 HOSTNAME: (optional) 445 Set to the hostname you'd like to be known as. Defaults to $ENV{HOSTNAME} 446 447 TIMEOUT: (optional) 448 Set to the number of seconds to timeout on freedb server. Defaults to 120 449 450 451 new() creates and returns a new Net::FreeDB object that is connected 452 to either the given host or freedb.freedb.org as default. 453 454=item lscat 455 456 Returns a list of all available categories on the server. 457 Sets $obj->error on error 458 459=item query($id, $num_trks, $trk_offset1, $trk_offset2, $trk_offset3...) 460 461 Parameters: 462 463 query($$$...) takes: 464 1: a discid 465 2: the number of tracks 466 3: first track offset 467 4: second track offset... etc. 468 469 Query expects $num_trks number of extra params after the first two. 470 471 query() returns an array of hashes. The hashes looks like: 472 473 { 474 Category => 'newage', 475 DiscID => 'discid', 476 Artist => 'artist', 477 Album => 'title' 478 } 479 480 Sets $obj->error on error 481 482 NOTE: query() can return 'inexact' matches and/or 'multiple exact' 483 matches. The returned array is the given returned match(es). 484 485=item read($server_category_string, $disc_id) 486 487 Parameters: 488 489 read($$) takes 2 parameters, the first being a server category name. 490 This can be any string either that you make up yourself or 491 that you believe the disc to be. The second is the disc id. This 492 may be generated for the current cd in your drive by calling get_local_disc_id() 493 494 Sets $obj->error on error 495 496 NOTE: 497 Using an incorrect category will result in either no return or an 498 incorrect return. Please check the CDDB::File documentation for 499 information on this module. 500 501 read() requests a freedb record for the given information and returns a 502 CDDB::File object. 503 504=item unlink($server_category_string, $disc_id) 505 506 Parameters: 507 508 1: a server category name 509 2: a valid disc_id 510 511 This will delete the given entry on the server (if you have permission). 512 Check the docs for the read() method to get more information on the parameters. 513 514 Sets $obj->error on error. 515 516=item write($server_category_string, $disc_id, $cddb_formatted_data) 517 518 Parameters: 519 520 1: a server category name 521 2: a valid disc_id 522 3: a properly formatted array of lines from a cddb file 523 524 Returns true on success, otherwise $obj->error will be set. 525 526=item discid($number_of_tracks, $track_1_offset, $track_2_offset, ..., $total_number_of_seconds_of_disc) 527 528 Parameters: 529 530 1: The total number of tracks of the current disc 531 2: An array of the track offsets in seconds 532 3: The total number of seconds of the disc. 533 534 Returns a valid disc_id if found, otherwise $obj->error will be set. 535 536=item get($filename) 537 538 Parameters: 539 540 1: The filename to retrieve from the server. 541 542 Returns a scalar containing raw file contents. Returns $obj->error on error. 543 544 545=item log($number_of_lines_per_section, start_date, end_date, 'day', $number_of_days, 'get') 546 547 Parameters: 548 549 1: The number of lines per section desired 550 2: (Optional) A date after which statistics should be calculated in the format of hh[mm[ss[MM[DD[[CC]YY]]]]] 551 3: (Optional) Must pass a start_date if passing this. A date after start date at which time statistics 552 to not be calculated in the format of hh[mm[ss[MM[DD[[CC]YY]]]]] 553 4: (Optional) The string 'day' to indicate that statistics should be calcuated for today. 554 5: (Optional) A number of days to be calculated, default is 1 555 6: (Optional) The string 'get' which will cause the log data to be recorded on the server's machine. 556 557 NOTE: You must provide at least one of the optional options (2,3,4). 558 Sets $obj->error on error. 559 560=item motd 561 562 Parameters: 563 None 564 565 Returns the message of the day as a string. 566 Sets $obj->error on error. 567 568=item proto($desired_protocol_level) 569 570 Parameters: (Optional) The desired protocol level as a number. 571 572 When called with NO parameters, will set the current and maximum allowed procotol levels, 573 when called with a desired protocol level it will be set, $obj->errror will be set if an error occurs. 574 575 Returns the currently selected protocol level. 576 577=item put($type, $file) 578 579 Parameters: 580 581 1: type is either sites or motd 582 2: based on param 1, an array of lines, either a list of mirror sites 583 or a new message of the day 584 585 Assuming you have permission to do so the server content will be updated. 586 Sets $obj->error on error. 587 588=item quit 589 590 Parameters: 591 None 592 593 Disconnects from the server. 594 595=item sites() 596 597 Parameters: 598 None 599 600 sites() returns an array reference of urls that can be used as 601 a new remote_host. 602 603=item stat 604 605 Parameters: 606 None 607 608 Returns undef on error (and sets $obj->error). Otherwise returns a hashref 609 where the keys/values are: 610 611 max proto => <current_level> 612 An integer representing the server's current operating protocol level. 613 614 gets => <yes | no> 615 The maximum protocol level. 616 617 updates => <yes | no> 618 Whether or not the client is allowed to initiate a database update. 619 620 posting => <yes | no> 621 Whether or not the client is allowed to post new entries. 622 623 quotes => <yes | no> 624 Whether or not quoted arguments are enabled. 625 626 current users => <num_users> 627 The number of users currently connected to the server. 628 629 max users => <num_max_users> 630 The number of users that can concurrently connect to the server. 631 632 strip ext => <yes | no> 633 Whether or not extended data is stripped by the server before presented to the user. 634 635 Database entries => <num_db_entries> 636 The total number of entries in the database. 637 638 <category_name => <num_db_entries> 639 The total number of entries in the database by category. 640 641=item update 642 643 Parameters: 644 645 None 646 647 Tells the server to update the database (if you have permission). 648 Sets $obj->error on error. 649 650=item validate($validating_string) 651 652 Parameters: 653 654 1: A string to be validated. 655 656 If you have permission, given a string the server will validate the string 657 as valid for use in a write call or not. 658 659 Sets $obj->error on error. 660 661=item ver 662 663 Parameters: 664 665 None 666 667 Returns a string of the server's version. 668 669=item whom 670 671 Parameters: 672 673 None 674 675 If you have permission, returns a list of usernames of all connected users. 676 Sets $obj->error on error. 677 678=item get_local_disc_id 679 680 Parameters: 681 getdiscid($) takes the device you want to use. 682 Basically this means '/dev/cdrom' or whatever on linux machines 683 but it's an array index in the number of cdrom drives on windows 684 machines starting at 0. (Sorry, I may change this at a later time). 685 So, if you have only 1 cdrom drive then getdiscid(0) would work fine. 686 687 getdiscid() returns the discid of the current disc in the given drive. 688 689 NOTE: See BUGS 690 691=item get_local_disc_data 692 693 Parameters: 694 getdiscdata($) takes the device you want to use. See getdiscid() 695 for full description. 696 697 getdiscdata() returns a hash of the given disc data as you would 698 require for a call to query. The returns hash look like: 699 700 { 701 ID => 'd00b3d10', 702 NUM_TRKS => '3', 703 TRACKS => [ 704 '150', 705 '18082', 706 '29172' 707 ], 708 SECONDS => '2879' 709 } 710 711 NOTE: A different return type/design may be developed. 712 713=back 714 715=head1 BUGS 716 717 The current version of getdiscid() and getdiscdata() 718 on the Windows platform takes ANY string in a single 719 cdrom configuration and works fine. That is if you 720 only have 1 cdrom drive; you can pass in ANY string 721 and it will still scan that cdrom drive and return 722 the correct data. If you have more then 1 cdrom drive 723 giving the correct drive number will return in an 724 accurate return. 725 726=head1 Resources 727 The current version of the CDDB Server Protocol can be 728 found at: http://ftp.freedb.org/pub/freedb/latest/CDDBPROTO 729 730=head1 AUTHOR 731 David Shultz E<lt>dshultz@cpan.orgE<gt> 732 Peter Pentchev E<lt>roam@ringlet.netE<gt> 733 734=head1 CREDITS 735 Jeremy D. Zawodny E<lt>jzawodn@users.sourceforge.netE<gt> 736 Pete Jordon E<lt>ramtops@users.sourceforge.netE<gt> 737 738=head1 COPYRIGHT 739 Copyright (c) 2002, 2014 David Shultz. 740 Copyright (c) 2005, 2006 Peter Pentchev. 741 All rights reserved. 742 This program is free software; you can redistribute it 743 and/or modify if under the same terms as Perl itself. 744 745=cut 746 747