Net-Hotline-0.83/004070000427010022003000000000000757122352700147565ustar00macintshalumni00000400000004Net-Hotline-0.83/lib/004070000427010022003000000000000757122352600155235ustar00macintshalumni00000400000004Net-Hotline-0.83/lib/Net/004070000427010022003000000000000757122352600162515ustar00macintshalumni00000400000004Net-Hotline-0.83/lib/Net/Hotline/004070000427010022003000000000000757122352700176545ustar00macintshalumni00000400000004Net-Hotline-0.83/lib/Net/Hotline/Task.pm010064400427010022003000000033150757122347300211250ustar00macintshalumni00000400000004package Net::Hotline::Task; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); $VERSION = '0.80'; sub new { my($class, @args) = @_; my($self); if(@args >= 3) { $self = { 'NUM' => $args[0], 'TYPE' => $args[1], 'START' => $args[2], 'SOCKET' => $args[3], 'PATH' => $args[4], 'FINISH' => undef, 'ERROR' => undef, 'ERRTXT' => undef, 'MISC' => $args[5], }; } else { $self = { 'NUM' => undef, 'TYPE' => undef, 'SOCKET' => undef, 'PATH' => undef, 'START' => undef, 'FINISH' => undef, 'ERROR' => undef, 'ERRTXT' => undef, 'MISC' => undef, }; } bless $self, $class; return $self; } sub num { $_[0]->{'NUM'} = $_[1] if($_[1] =~ /^\d+$/); return $_[0]->{'NUM'}; } sub type { $_[0]->{'TYPE'} = $_[1] if(defined($_[1])); return $_[0]->{'TYPE'}; } sub path { $_[0]->{'PATH'} = $_[1] if(defined($_[1])); return $_[0]->{'PATH'}; } sub socket { $_[0]->{'SOCKET'} = $_[1] if($_[1] =~ /^\d+$/); return $_[0]->{'SOCKET'}; } sub start { $_[0]->{'START'} = $_[1] if($_[1] =~ /^\d+$/); return $_[0]->{'START'}; } sub finish { $_[0]->{'FINISH'} = $_[1] if($_[1] =~ /^\d+$/); return $_[0]->{'FINISH'}; } sub error { $_[0]->{'ERROR'} = $_[1] if(@_ == 2); return $_[0]->{'ERROR'}; } sub error_text { $_[0]->{'ERRTXT'} = $_[1] if(@_ == 2); return $_[0]->{'ERRTXT'}; } sub misc { $_[0]->{'MISC'} = $_[1] if(@_ == 2); return $_[0]->{'MISC'}; } 1; Net-Hotline-0.83/lib/Net/Hotline/PrivateChat.pod010064400427010022003000000031100757122347300225740ustar00macintshalumni00000400000004=head1 NAME Net::Hotline::PrivateChat - Private chat object used internally by Net::Hotline::Client =head1 SYNOPSIS use Net::Hotline::PrivateChat; $pchat = new Net::Hotline::PrivateChat; $pchat->subject("Issue 1: Monkey beards"); $pchat->reference(0x313337); ... =head1 DESCRIPTION Net::Hotline::PrivateChat is a simple class for storing and retrieving private chat information, You should never have to create your own Net::Hotline::PrivateChat objects when using Net::Hotline::Client. Getting and (to a lesser extent) setting attributes is all that should be necessary. =head1 CONSTRUCTION =over 4 =item new REF, USERLIST, SUBJECT Creates a new Net::Hotline::PrivateChat object with the reference REF, userlist USERLIST, and subject SUBJECT, where REF is a number, USERLIST is a reference to a hash of Net::Hotline::User objects keyed by socket number, and SUBJECT is a string. Any missing arguments will be set to undef. =back =head1 METHODS All the Net::Hotline::PrivateChat methods are simple attribute get/set routines. If given an argument, they set an attribute. In all cases, they return the current value of the attribute. =over 4 =item reference NUM The private chat reference number. =item subject TEXT The subject of the private chat. =item userlist HASHREF The list of users in the private chat. =back =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Hotline-0.83/lib/Net/Hotline/Client.pod010064400427010022003000001247170757122346700216240ustar00macintshalumni00000400000004=head1 NAME Net::Hotline::Client - Perl library for the Hotline internet client =head1 SYNOPSIS use Net::Hotline::Client; $hlc = new Net::Hotline::Client; $hlc->connect("127.0.0.1") $hlc->chat_handler(\&Chat_Handler); $hlc->msg_handler(\&Msg_Handler); $hlc->login(Login => "Steve", Password => "xyzzy", Nickname => "Jobs", Icon => 128); $hlc->run(); ... =head1 DESCRIPTION Net::Hotline::Client is a class implementing a Hotline internet client in Perl. It was specifically developed to aid in the creation of Hotline "bots," although it's suitable for most other tasks as well. Hotline is an internet client/server system that's sort of a cross between IRC and a BBS. See http://www.hotlinesw.com/ for more information. This document assumes you have some knowledge of the Hotline client. If not, I suggest downloading it from the URL above. (It's shareware. Mac and PC versions are available) =head1 CAVEATS The Hotline protocol is not public. (An RFC? I wish!) This module got its start with the aid of the C source code from the Unix "hx" Hotline client written by Ryan Nielsen, the beginnings of a Java Hotline bot written by Gary Wong, and many hours spent staring at hexdumps of network data. Some features are still not implemented, the most notable being user administration capabilities. Finally, I'm sure all hell will break loose with the next major revision of Hotline. Such is life. =head1 GETTING STARTED Before delving into the nitty-gritty details, it's important to understand the philosophy behind design of this module. If you do not read this section first, you will probably be confused by the rest of the documentation. Take the time now and save yourself headaches later. Hotline is an event-driven protocol. A Hotline client receives packets each time something interesting occurs on the server--a new user joins, someone says something in chat, someone goes idle, etc. The client receives these packets whether it's ready for them or not. This type of interaction lends itself to an event-loop/callback-routine design, which is how this module was originally implemented. Handler routines are set for the events you're interested in, and then the event loop is started. In this model, client actions are also treated as events. To retrieve the news, for example, the client calls a function that sends a news request to the server and returns a task ID number. The client then returns to the event loop and watches the incoming packet stream for a packet with the same task ID (it will be either a packet containing the news or a task error packet). In the time between when the news request was sent and the response is received from the server, many other unrelated events can (and probably will) occur. This system works great for things like bots that want to deal with events in a non-linear fashion, but what about when you want to do things in a more deterministic manner? For example, imagine trying to implement a command line FTP-like Hotline client using the event loop model. Sure, it's possible, but it's not pretty! I found this out the hard way. What's needed are what I'm going to call "blocking tasks." That is, function calls that don't return until their work is done. In this new model, the news request function would not merely return a task ID number, it would return the news itself (or an error, of course). To accomplish this, the "blocking task" version of the news retrieval function has to do everything that you'd do in the event loop model: send a request for the news and watch the incoming packet stream for the task results. There's no magic here. Of course, the question of what to do with those "unrelated" packets presents itself. They can't just be ignored because they may be telling the client something important like "you've just been disconnected." On the other hand, allowing them to invoke handler routines might spin us off into another section of the code indefinitely. The solution I came up with is to let the user decide. All unrelated events that occur during blocking tasks are subject to the bare minimum processing needed to keep the internal state of the client object consistent (tracking joining and leaving users, disconnect messages, etc.). Going further, handler routines can indeed be called. The behavior is controlled by the client object's attributes. These two modes of operation are called "event loop mode" and "blocking task mode" in the rest of the documentation. It's important to decide which model suits your particular needs before starting your Hotline client code. Blindly mixing and matching these techniques will get you nowhere fast. Now, on to the good stuff... =head1 METHODS =head2 CONNECTING =over 4 =item connect ADDRESS Opens a network connection to ADDRESS, which can be an IP address or hostname optionally followed by a space or a colon and a port number. If no port is given, it defaults to 5500 (Hotline standard port) Examples: $hlc->connect("127.0.0.1:1234"); $hlc->connect("hostname.com 5678"); Returns 1 if successful, undef otherwise. =item disconnect Closes the network connection. Returns 1 if a connection was closed, undef if the connection wasn't open to begin with. =item login PARAMETERS Logs into a Hotline server opened via C, and requests the news and the userlist (unless overridden by the "NoNews" and "NoUserList" parameters). Arguments are in a "named parameter" format, and are case-sensitive. The parameters are: Nickname Your nickname (default: guest) Login Your account name (default: guest) Password Your account password (default: ) Icon Your icon number (default: 410, the big red "H") NoNews If true, do not request the news. NoUserList If true, do not request the userlist. Example of use: $hlc->login(Login => "Steve", Password => "xyzzy", Nickname => "Jobs", Icon => 128, NoNews => 1); If omitted, all parameters except Password will default to some sane (if not necessarily "sensible") value. The news and userlist will be requested unless NoNews and/or NoUserList are explicitly set by the user. Keep in mind that client functions like the tracking of connected users will not work properly without the userlist. In blocking task mode, login() returns 1 on success, undef if an error occurred, and "zero but true" ("0E-0") if the login was successful, but the news and/or userlist retrieval failed. In event loop mode, login() returns the task number if the login request was sent successfully, undef otherwise. =item run Starts the event loop. Returns when the connection has to the server has been closed. =back =head2 SETTINGS =over 4 =item blocking EXPR Turns blocking network i/o on or off depending on how EXPR evaluates (true turns blocking i/o on). Returns the current setting. Blocking i/o is on by default. In this mode, the event loop will cycle each time data of any kind comes from the server. This means that your hotline client may spend a lot of its time blocked (and therefore unable to do anything interesting) waiting for something to happen on the server. Using non-blocking i/o will cycle through the event loop more frequently (see C below) regardless of server activity. =item blocking_tasks EXPR With no arguments, returns the blocking task status. With one argument, blocking tasks will be turned on or off depending on how EXPR evaluates (true means blocking task mode is active). Blocking tasks are off by default. =item clear_error Clears the error message text available via C. C is not cleared by the client object, so you may need to explicitly clear it before running a blocking task to prevent it from containing an old, unrelated error message if the blocking task somehow failed without setting C. (This should not happen, but you never know...) =item connect_timeout SECS Sets the connection timeout to SECS seconds (if present). Returns the current connection timeout. =item data_fork_extension TEXT Sets the data fork filename extension for downloads to TEXT (if present). Returns the current data fork filename extension. The default setting is ".data" =item downloads_dir PATH Sets the directory where downloaded files are placed to PATH (if present). Returns the current setting. =item event_timing SECS Sets the event loop timing to SECS seconds (if present). Fractional seconds are allowed. The default setting is 1 second. This option only has an effect when non-blocking i/o is active (see C). Returns the current event timing setting. =item handlers_during_blocking_tasks EXPR Allows handlers to run during blocking tasks if EXPR is present and evaluates to true. Returns the current setting. The default setting is off. =item path_separator CHARACTER Sets the path separator to CHARACTER (if present). The default setting is the Mac OS path separator ":". Returns the current value of the path separator. Note that this is the path separator used when sending commands to the server and has no bearing on what the path separator is on the local system. You should not need to change this, since all current Hotline servers use ":" regardless of the platform they're running on. =item rsrc_fork_extension TEXT Sets the resource fork filename extension for downloads to TEXT (if present). Returns the current resource fork filename extension. The default setting is ".rsrc" =item tracker ADDR Sets the tracker address to ADDR (if present), where ADDR is an IP address or hostname, optionally followed by a colon and a port number. Returns the current tracker address. =item xfer_bufsize BYTES Sets the file transfer buffer size to BYTES. Returns the current buffer size. The default is 4096 bytes. =back =head2 COMMANDS Unless otherwise specified, the methods in this section are treated as "tasks" by Hotline. Their status (start time, finish time, error state, etc.) is tracked internally by task number. In event mode, they return a task number if the request was sent successfully, and undef or an empty list if an error occurred. In blocking task mode, the return values vary. Some commands (like C and C, for example) are not treated as "tasks" by Hotline. They always return 1 on success, rather than a task number. The actual completion of a such commands can only be determined by examining the resulting data from the server. For example, if you C, you can look for that line of chat in your chat handler. (This is rarely necessary since the failure of such a command usually means that you have much bigger problems.) =over 4 =item ban USER =item ban SOCKET Bans the user specified by a Net::Hotline::User object or a user socket number. In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item chat LIST Sends the text formed by the concatenation of LIST to the server as "chat." Perl newlines ("\n") are translated to Net::Hotline::Constants::HTLC_NEWLINE, which is Hotline's native newline character. Not treated as a task: returns 1 on success, undef or an empty list on failure. =item chat_action LIST Sends the text formed by the concatenation of LIST to the server as a "chat action." Perl newlines ("\n") are translated to Net::Hotline::Constants::HTLC_NEWLINE, which is Hotline's native newline character. Not treated as a task: returns 1 on success, undef or an empty list on failure. =item comment PATH, TEXT Sets the comments for the file or folder located at PATH to TEXT. If TEXT is undef or an empty string, the comments for the file or folder will be removed. In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item delete_file PATH Deletes the file or folder located at located at PATH. In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item get_file PATH Download the file on the server located at PATH to the local directory set via C. In Mac OS, file names longer than 31 characters are truncated, preserving the filename extension (i.e. ".jpg") if possible. In blocking task mode, returns either an array (in array context) or a reference to an array (in scalar context) containing a Net::Hotline::Task object, a download reference number, and the size of the download on success, an undef or an empty list if an error occurred. Those return values are meant to be fed to C like this (error handling omitted): ($task, $ref, $size) = $hlc->get_file("Folder1:file.sit"); $hlc->recv_file($task, $ref, $size); In event loop mode, returns a task number if the request was sent successfully, and undef or an empty list if an error occurred. =item get_file_resume PATH Resume downloading the file on the server located at PATH to the local directory set via C. The partially downloaded file(s) must exist in the local download directory, and (on non-Mac OS systems) must have filename extensions matching the current settings of C and C. In blocking task mode, returns either an array (in array context) or a reference to an array (in scalar context) containing a Net::Hotline::Task object, a download reference number, and the size of the download on success, and undef or an empty list if an error occurred. Those return values are meant to be fed to C like this (error handling omitted): ($task, $ref, $size) = $hlc->get_file_resume("Folder1:file.sit"); $hlc->recv_file($task, $ref, $size); In event loop mode, returns a task number if the request was sent successfully, and undef or an empty list if an error occurred. =item get_fileinfo PATH Returns a Net::Hotline::FileInfoItem object corresponding to the file specified by PATH, or undef if an error occurred. Should only be used in blocking task mode. =item get_filelist PATH Returns an array (in array context) or a reference to an array (in scalar context) of Net::Hotline::FileListItem objects corresponding to the contents of the server directory PATH, and the scalar value 0 if an error occurred (in order to distinguish between an empty directory and an error: an empty directory will return an empty list in array context and undef in scalar context). Should only be used in blocking task mode. =item get_news Get the news from the server. Returns an array containing the new posts (in array context) or the news as a string (in scalar context) on success, and undef if an error occurred. Note that successful retrieval of an empty news file will return an empty string ("") or an empty list. Should only be used in blocking task mode. =item get_userinfo SOCKET Returns information about the user specified by SOCKET as a string, or undef if there was an error. Will not work unless the userlist has been retrieved from the server. Should only be used in blocking task mode. =item get_userlist Returns a reference to a hash keyed by socket number containing Net::Hotline::User objects for all users currently logged on. Should only be used in blocking task mode. =item icon ICON Sets your icon in the userlist to ICON, where ICON is an icon ID number. =item kick USER =item kick SOCKET Disconnects the user specified by a Net::Hotline::User object or a user socket number. In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item macbinary MACBIN_FILE, DATA_FILE, DATA_LEN, RSRC_FILE, RSRC_LEN BUF_SIZE, TYPE, CREATOR, COMMENTS, CREATED, MODIFIED, FINDER_FLAGS Creates a MacBinary II file at the path designated by MACBIN_FILE based on the file paths and other information supplied as arguments (see the C method for a description of the other arguments). If MACBIN_FILE is undefined, it defaults to DATA_FILE with ".bin" tacked onto the end. It returns 1 on success, and undef if MACBIN_FILE already exists or can't be created, if DATA_LEN is greater than zero and DATA_FILE can't be opened, or if RSRC_LEN is greater than zero and RSRC_FILE can't be opened. The error condition is available via both C and $! because macbinary() can be called as a method or as a function. Example: # As a method unless($hlc->macbinary(@args)) { die "macbinary: ", $hlc->last_error(); } # As a function unless(macbinary(@args)) { die "macbinary: $!"; } =item move SRC, DEST Moves the file or folder located at the path SRC to the directory located at the path DEST. SRC should be the full path to the file or folder you want to move, and DEST should be the full path to the B you want to move SRC too. The file or folder name should only appear in the SRC path, never in the DEST path. As a consequence, renaming files or folders must be done through C and cannot be rolled into a C call. Here's an example of a valid call to C: $hlc->move("Folder1:file1", "Folder2:"); This moves the "file1" from "Folder1" to "Folder2" In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item msg USER, LIST =item msg SOCKET, LIST Sends the text formed by the concatenation of LIST as a private message to the user specified by a Net::Hotline::User object or a user socket number. In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item new_folder PATH Create a new folder located at PATH. In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item nick TEXT Sets your nickname in the userlist to TEXT. =item pchat REF, LIST Sends the text formed by the concatenation of LIST to the private chat window specified by REF. Perl newlines ("\n") are translated to Net::Hotline::Constants::HTLC_NEWLINE, which is Hotline's native newline character. Not treated as a task: returns 1 on success, undef or an empty list on failure. =item pchat_action REF, LIST Sends the text formed by the concatenation of LIST to the private chat window specified by REF as a "chat action". Perl newlines ("\n") are translated to Net::Hotline::Constants::HTLC_NEWLINE, which is Hotline's native newline character. Not treated as a task: returns 1 on success, undef or an empty list on failure. =item pchat_accept REF Accepts an invitaton to the private chat sepcified by REF. In blocking task mode, returns 1 on success. In event loop mode, returns a task number if the request was sent successfully. In both modes, it returns undef or an empty list if an error occurred. =item pchat_decline REF Declines an invitaton to the private chat sepcified by REF. Not treated as a task: returns 1 on success, undef or an empty list on failure. =item pchat_invite SOCKET, REF Invite the user specified by SOCKET to an existing private chat specfied by REF, or create a new private chat if REF is not given. There is no C command. To create a new private chat, you must invite someone. Call C with your own socket number and no REF argument to create a new private chat with only yourself in it (you will not have to explicitly accept this invitation). In blocking task mode, returns 1 on success, and undef or an empty list if an error occurred. In event mode, it returns a task number if it had to create a new private chat (i.e. if no REF argument was given) or 1 (if inviting to an existing private chat) on success, and undef or an empty list if an error occurred. =item pchat_leave REF Leave the private chat specified by REF. Not treated as a task: returns 1 on success, undef or an empty list on failure. =item pchat_subject REF, TEXT Sets the subject of the private chat specified by REF to TEXT. Not treated as a task: returns 1 on success, undef or an empty list on failure. =item post_news LIST Sends the text formed by the concatenation of LIST to the server as a news post. In blocking task mode, returns 1 on success. In event loop mode, returns a task number if the request was sent successfully. In both modes, it returns undef or an empty list if an error occurred. =item put_file SRC_PATH, DEST_PATH, COMMENT Upload the file located at SRC_PATH to the server directory DEST_PATH, with the file comments COMMENT. SRC_PATH must be in the native path format of the local system (i.e. using ":" as the path separator on Mac OS, and "/" on most other OSes). DEST_PATH must be in Hotline's native path format (":" as the path separator). If COMMENT is omitted, the actual Finder comments will be read from the file to be uploaded if running on Mac OS. Otherwise, the comments will be blank. C tries to upload a new file. If you are resuming a file upload, you must call C instead. In blocking task mode, returns an array (in array context) or a reference to an array (in scalar context) containing a Net::Hotline::Task object, an upload reference number, and the size of the upload, and undef or an empty list if an error occurred. Those return values are meant to be fed to C like this (error handling omitted): ($task, $ref, $size) = $hlc->put_file("/home/john/file.gz", "Folder1:Folder2" "A fun file!"); $hlc->send_file($task, $ref, $size); In event loop mode, returns a task number if the request was sent successfully, and undef or an empty list if an error occurred. =item put_file_resume SRC_PATH, DEST_PATH, COMMENT Resume uploading the file located at SRC_PATH to the server directory DEST_PATH, with the file comments COMMENT. SRC_PATH must be in the native path format of the local system (i.e. using ":" as the path separator on Mac OS, and "/" on most other OSes). DEST_PATH must be in Hotline's native path format (":" as the path separator). If COMMENT is omitted, the actual Finder comments will be read from the file to be uploaded if running on Mac OS. Otherwise, the comments will be blank. Use C to upload a new file. In blocking task mode, returns an array (in array context) or a reference to an array (in scalar context) containing a Net::Hotline::Task object, an upload reference number, the size of the upload, and additional information needed to resume the upload, and undef or an empty list if an error occurred. Those return values are meant to be fed to C like this (error handling omitted): ($task, $ref, $size, $rflt) = $hlc->put_file_resume("/home/john/file.gz", "Folder1:Folder2" "A fun file!"); $hlc->send_file($task, $ref, $size, $rflt); In event loop mode, returns a task number if the request was sent successfully, and undef or an empty list if an error occurred. =item recv_file TASK, REF, SIZE Starts receiving the file designated by the Net::Hotline::Task object TASK, the download reference number REF, and the size in bytes SIZE returned by C (in blocking task mode) or supplied to the C handler routine (in event loop mode). When the download is complete, C returns a reference to an array containing the following values: DATA_FILE Path to the file containing the data fork. DATA_LEN Length of the data fork. RSRC_FILE Path to the file containing the Mac resource fork. RSRC_LEN Length of the resource fork. BUFSIZE Buffer size that was used during the download. TYPE Four-letter Mac file type code. CREATOR Four-letter Mac file creator code. COMMENTS Mac Finder comments. CREATED Date created (in Mac time format) MODIFIED Date modified (in Mac time format) FINDER_FLAGS Mac finder flags packed in two bytes. which are typically fed to the C method to create a single MacBinary II file from the separate resource fork and data fork files. (On Mac OS systems, a single Mac OS-native two-forked file is created, so there's no need to call C) Here's an example of typical usage (error checking omitted): # Event loop mode: # (Inside your get_file() handler subroutine) ... $ret = $hlc->recv_file($task, $ref, $size); $hlc->macbinary(undef, $ret); ... or # Blocking task mode: ... ($task, $ref, $size) = $hlc->get_file($path); $ret = $hlc->recv_file($task, $ref, $size); $hlc->macbinary(undef, $ret) ... See C for more details on its usage. If either the data fork or resource fork is empty, the fork length returned by C will be zero and the file path returned will be undef. =item rename PATH, NAME Renames the file or folder located at PATH to NAME. Note that PATH is the full path to the target, but NAME is just the new name without any path specification. Example: $hlc->rename("Pets:cat", "dog"); This changes the name of the file "cat" in the folder "Pets" to "dog" In blocking task mode, returns 1 on success or undef if an error occurred. In event loop mode, returns a task number if the request was sent successfully, or undef if an error occurred. =item send_file TASK, REF, SIZE, RFLT Starts sending the file designated by the Net::Hotline::Task object TASK, the upload reference number REF, the size in bytes SIZE, and the resume information RFLT returned by C (in blocking task mode) or supplied to the C handler routine (in event loop mode). Returns 1 if the upload completed successfully, or undef if there was an error. =item tracker_list TIMEOUT Connects to the server set via the C method and retrieves the list of servers tracked by that tracker. Returns an array (in array context) or a reference to an array (in scalar context) of Net::Hotline::TrackerListItem objects on success, and undef or an empty list on failure, with the error condition available via C. The initial connection to the tracker will timeout after TIMEOUT seconds, or the current value set via C if TIMEOUT is omitted. A TIMEOUT value of zero will disable the timeout. Note that this method does not return until it has retrieved the list of tracked servers, and that the timeout applies B to the initial connection to the tracker. It is often the case with overloaded trackers that this method will hang when writing to or reading from the tracker (regardless of the timeout value), many times resulting in a C with a broken pipe error in one of the network I/O functions. To avoid this, either try a more responsive tracker and/or wrap your C call in an C block and check C<$@>. =back =head2 REQUESTS All the methods in this section are treated as "tasks" by Hotline. Their status (start time, finish time, error state, etc.) is tracked internally by task number. They return a task number if the request was sent successfully, undef otherwise. When a tasks completes, the data is stored in the appropriate Net::Hotline::Client attribute. For example, when a C task completes, the data is available via the news() method. =over 4 =item req_filelist PATH Requests the file listing for the folder specified by PATH, or the root directory if PATH is omitted. =item req_fileinfo PATH Requests the file information for the file or folder specified by PATH. =item req_news Requests the news from the server. =item req_userinfo SOCKET Requests user information for the user specified by SOCKET. =item req_userlist Request the list of users currently logged on. =back =head2 ATTRIBUTES The methods in this section return data or references to data structures in the Net::Hotline::Client object. Some data structures contain references to objects. For details on those objects, see their respective documentation (i.e. perldoc Net::Hotline::User) =over 4 =item agreement Returns a reference to the server's user agreement text, or undef if there is none. =item connected Returns true if a network connection to a server is open. =item files Returns a reference to a hash of arrays containing Net::Hotline::FileListItem objects, keyed by directory path. Here's some sample code that prints the entire file tree: $files = $hlc->files(); # Get reference to the file tree foreach $directory (keys(%{$files})) { print "$directory\n"; # Ex: "Uploads:Pictures" foreach $file (@{$files->{$directory}}) { print "\t", $file->name(), "\n"; # Ex: "Picture.jpg" } } =item last_activity Returns the time the last packet was received from the server in the system's native C format. (Usually seconds since the Unix epoch. MacPerl is probably the only odd-ball) =item last_error Returns a text error message detailing the last error that occurred. Use this method to determine the cause of failure when a blocking task returns undef. Example: ... $hlc->blocking_tasks(1); ... $hlc->get_filelist("Folder1") || die $hlc->last_error(); Don't rely on C unless you're in blocking task mode. In event loop mode, set a handler routine via C and deal with errors there via the task object's C and C methods. =item logged_in Returns true if currently logged into a server. =item news Returns a reference to an array of news posts, or undef if the news has not yet been requested or is empty. =item pchats Returns a reference to a hash of Net::Hotline::PrivateChat objects, keyed by reference number, that represent all the private chats that the client is currently engaged in, or undef or an empty list if not in any private chats. =item server Returns the address of the server currently connected to as a hostname or IP address, depending on what the actual argument to C was. If the port connected to is anything other than the standard Hotline port (5500), then a colon and the port number are tacked onto the end of the server name. If not connected at all, undef is returned. =item userlist Returns a reference to a hash of Net::Hotline::User objects keyed by socket number, or undef if the userlist has not yet been received. =item user_by_nick REGEX Returns reference(s) to user objects with nicknames matching REGEX, and undef or an empty list if there are no matches. Also returns undef or an empty list if called before the userlist has been retrieved from the server. REGEX is treated as a case-sensitive anchored regular expression internally (i.e. C). If your regex matches more than one user's nickname, and C was called in array context, an array of references to user objects will be returned. Otherwise, the first user object that matched will be returned (as ordered by socket number, from low to high). =item user_by_socket SOCKET Returns the user object whose socket number is equal to SOCKET, or undef if there is no user at that socket. =back =head2 HANDLERS The methods in this section deal with getting and setting the handler routines for events and tasks. If you do not set your own handler for an event, the default handler (usually just a print to STDOUT) will be used. You can enable and disable the default handlers with the C method. They are disabled by default. =over 4 =item default_handlers EXPR If EXPR is omitted, it returns the default handler setting. Otherwise, it sets the default handler setting to EXPR (anything that evaluates to true is considered "on"). Default handlers are disabled by default. =item handlers Returns a reference to a hash, keyed by event type strings (the strings in CAPS below). The values associated with the keys are either code references or undef. Event types are as follows: Events: AGREEMENT User agreement text received. CHAT New chat appeared. CHAT_ACTION A new chat "action" appeared. COLOR A user changed color in the userlist. EVENT Next cycle in the event loop. ICON A user changed icon in the userlist. JOIN A user joined the server. LEAVE A user left the server. MSG A private message arrived. NEWS News received. NEWS_POSTED A news post was made by another user. NICK A user changed nickname in the userlist. PCHAT_CHAT New private chat appeared. PCHAT_ACTION A new private chat action appeared. PCHAT_INVITE An invitation to private chat arrived. PCHAT_JOIN A user joined a private chat. PCHAT_LEAVE A user left a private chat. PCHAT_SUBJECT Private chat subject changed. QUIT The server was shutdown politely. SERVER_MSG A server message arrived. Tasks: BAN Ban user task completed. FILE_DELETE A file or folder was deleted. FILE_GET A file download is ready to begin. FILE_PUT A file upload is ready to begin. FILE_GET_INFO File information received. FILE_SET_INFO File information set. FILE_LIST File list received. FILE_MKDIR New folder created. FILE_MOVE A file or folder was moved. KICK Disconnect user task completed. LOGIN Login task completed. NEWS_POST News post task completed. PCHAT_ACCEPT You have joined a private chat. PCHAT_CREATE New private chat created. SEND_MSG Private message sent. TASK_ERROR A task error ocurred. USER_GETINFO User information received. USER_LIST User list received. =back =head2 SET/GET HANDLERS The methods in this section expect either one code reference argument, or no arguments at all. With one argument, the handler is set to the given code reference. The return value is always the current value of the handler (should be either undef or a code reference). The code reference should point to a subroutine that expects at least one argument: the Net::Hotline::Client object itself (listed as "SELF" below). Other arguments vary according to the event being handled. In this section, only the varying arguments to the handler subroutine are described. Also note that you don't have to do the "obvious" tasks associated with each handler. For example, in the "leave" handler, you don't have to remove the user from the userlist. That will be done for you by the Net::Hotline::Client object. =over 4 =head2 EVENTS =item agreement_handler CODE (SELF, TEXT) User agreement text received. TEXT Reference to the agreement text. =item chat_handler CODE (SELF, TEXT) New chat appeared. TEXT Reference to the chat text. =item chat_action_handler CODE (SELF, TEXT) A new chat "action" appeared. TEXT Reference to the chat action text. =item color_handler CODE (SELF, USER, OLD_COLOR, NEW_COLOR) A user changed color in the userlist. USER A Net::Hotline::User object. OLD_COLOR The user's previous color. NEW_COLOR The user's new color. Valid colors: 1 Black Active normal user. 2 Red Active admin user. 3 Gray Inactive normal user. 4 Pink Inactive admin user. The hash C<%Net::Hotline::Constants::HTLC_COLORS> contains color number-to-name mappings. =item event_loop_handler CODE (SELF, IDLE) Next cycle in the event loop. Idle events only occur when non-blocking i/o is active. IDLE True if the event is an idle event. =item icon_handler CODE (SELF, USER, OLD_ICON, NEW_ICON) A user changed icon in the userlist. USER A Net::Hotline::User object. OLD_ICON The user's previous icon number. NEW_ICON The user's new icon number. =item join_handler CODE (SELF, USER) A user joined the server. USER A Net::Hotline::User object. =item leave_handler CODE (SELF, USER) A user left the server. USER A Net::Hotline::User object. =item msg_handler CODE (SELF, USER, TEXT, REPLY-TO) A private message arrived. USER Reference to the sender's Net::Hotline::User object. TEXT Reference to the message text. REPLY-TO Reference to the text to which this is a reply (if any) =item news_posted_handler CODE (SELF, TEXT) A news post was made by another user. TEXT Reference to the news post text. =item nick_handler CODE (SELF, USER, OLD_NICK, NEW_NICK) A user changed nickname in the userlist. USER A Net::Hotline::User object. OLD_NICK The user's previous nickname. NEW_NICK The user's new nickname. =item pchat_action_handler (SELF, REF, TEXT) A new private chat action appeared. REF Private chat reference number. TEXT Reference to the chat action text. =item pchat_chat_handler (SELF, REF, TEXT) New private chat appeared. REF Private chat reference number. TEXT Reference to the chat text. =item pchat_invite_handler (SELF, REF, SOCKET, NICK) An invitation to private chat arrived. REF Private chat reference number. SOCKET Socket number of the inviting user. NICK Nick of the inviting user. =item pchat_join_handler (SELF, PCHAT, SOCKET) A user joined a private chat. PCHAT A Net::Hotline::PrivateChat object. SOCKET Socket number of the joining user. =item pchat_leave_handler (SELF, PCHAT, SOCKET) A user left a private chat. PCHAT A Net::Hotline::PrivateChat object. SOCKET Socket number of the leaving user. Note that the user who left will no longer be in the private chat object's userlist. =item pchat_subject_handler (SELF, REF, TEXT) Private chat subject changed. REF Private chat reference number. TEXT Reference to the subject text. =item quit_handler CODE (SELF, TEXT) The server was shutdown politely. TEXT Reference to shutdown message text. =item server_msg_handler CODE (SELF, TEXT) A server message arrived. TEXT Reference to the message text. =head2 TASKS =item ban_handler CODE (SELF, TASK) Ban user task completed. TASK A Net::Hotline::Task object. =item delete_file_handler CODE (SELF, TASK) A file or folder was deleted. TASK A Net::Hotline::Task object. =item file_info_handler CODE (SELF, TASK, INFO) File information received. TASK A Net::Hotline::Task object. INFO A Net::Hotline::FileInfoItem object. =item file_list_handler CODE (SELF, TASK) File list received. TASK A Net::Hotline::Task object. =item get_file_handler CODE (SELF, TASK, REF, SIZE) A file download is ready to begin. TASK A Net::Hotline::Task object. REF Download reference number. SIZE Size of download in bytes. If you do not set a handler for C, a default handler will be used regardless of your C setting. The default handler simply does: SELF->recv_file(TASK, REF, SIZE); which initiates the file download and does not return until the download has completed. If you want to download in the background, call C (or something similar) in your handler routine. =item kick_handler CODE (SELF, TASK) Disconnect user task completed. TASK A Net::Hotline::Task object. =item login_handler CODE (SELF, TASK) Login task completed. TASK A Net::Hotline::Task object. =item move_file CODE (SELF, TASK) A file or folder was moved. TASK A Net::Hotline::Task object. =item new_folder CODE (SELF, TASK) New folder created. TASK A Net::Hotline::Task object. =item news_handler CODE (SELF, TASK) The news has arrived and is now available via the C method. TASK A Net::Hotline::Task object. =item pchat_accept_handler (SELF, TASK, PCHAT) You have joined a private chat. TASK A Net::Hotline::Task object. PCHAT A Net::Hotline::PrivateChat object. =item pchat_create (SELF, TASK, PCHAT) New private chat created. TASK A Net::Hotline::Task object. PCHAT A Net::Hotline::PrivateChat object. Note that you do not have to save the private chat object yourself. The client object keeps track of all private chats it is currently engaged in (the list is accessible via the C method), updates the userlists as users join and leave, and deletes the objects when you leave the private chat. =item post_news_handler CODE (SELF, TASK) News post task completed. TASK A Net::Hotline::Task object. =item put_file_handler CODE (SELF, TASK, REF, SIZE, RFLT) A file upload is ready to begin. TASK A Net::Hotline::Task object. REF Download reference number. SIZE Size of the upload in bytes. RFLT Data needed to resume an upload. If you do not set a handler for C, a default handler will be used regardless of your C setting. The default handler simply does: SELF->send_file(TASK, REF, SIZE, RFLT); which initiates the file upload and does not return until the upload has completed. If you want to upload in the background, call C (or something similar) in your handler routine. =item send_msg_handler CODE (SELF, TASK) Private message sent. TASK A Net::Hotline::Task object. =item set_file_info_handler CODE (SELF, TASK) File information set (this includes both renaming and setting file comments). TASK A Net::Hotline::Task object. =item task_error_handler CODE (SELF, TASK) A task error ocurred. TASK A Net::Hotline::Task object. =item user_info_handler CODE (SELF, TASK) User information received. TASK A Net::Hotline::Task object. =item user_list_handler CODE (SELF, TASK) User list received. TASK A Net::Hotline::Task object. =back =head2 MISCELLANEOUS =over 4 =item debug EXPR If EXPR is omitted, returns the debugging status (off by default), otherwise sets debugging status to EXPR (true means debugging is on). =item version Returns the Net::Hotline::Client version string. =back =head1 TO DO =over 4 =item * User administration. =back =head1 BUGS Please send bug reports to siracusa@mindspring.com. =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. News received. NEWS_POSTED A news postNet-Hotline-0.83/lib/Net/Hotline/TrackerListItem.pm010064400427010022003000000023260757122347400232730ustar00macintshalumni00000400000004package Net::Hotline::TrackerListItem; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); $VERSION = '0.80'; sub new { my($class, @args) = @_; my($self); if(@args == 5) { $self = { 'ADDRESS' => $args[0], 'PORT' => $args[1], 'NUM_USERS' => $args[2], 'NAME' => $args[3], 'DESCRIPTION' => $args[4] }; } else { $self = { 'ADDRESS' => undef, 'PORT' => undef, 'NUM_USERS' => undef, 'NAME' => undef, 'DESCRIPTION' => undef }; } bless $self, $class; return $self; } sub address { $_[0]->{'ADDRESS'} = $_[1] if(@_ == 2); return $_[0]->{'ADDRESS'}; } sub port { $_[0]->{'PORT'} = $_[1] if(@_ == 2); return $_[0]->{'PORT'}; } sub num_users { $_[0]->{'NUM_USERS'} = $_[1] if(@_ == 2); return $_[0]->{'NUM_USERS'}; } sub name { $_[0]->{'NAME'} = $_[1] if(@_ == 2); return $_[0]->{'NAME'}; } sub description { $_[0]->{'DESCRIPTION'} = $_[1] if(@_ == 2); return $_[0]->{'DESCRIPTION'}; } 1; Net-Hotline-0.83/lib/Net/Hotline/Task.pod010064400427010022003000000055110757122347300212730ustar00macintshalumni00000400000004=head1 NAME Net::Hotline::Task - Task object used internally by Net::Hotline::Client =head1 SYNOPSIS use Net::Hotline::Task; $task = new Net::Hotline::Task; $task->start(time()); $task->num($num++); ... =head1 DESCRIPTION Net::Hotline::Task is a simple class for storing and retrieving task information, You should never have to create your own Net::Hotline::Task objects when using Net::Hotline::Client. Getting and (to a lesser extent) setting attributes is all that should be necessary. =head1 CONSTRUCTION =over 4 =item new NUM, TYPE, START, SOCKET, PATH With no arguments, creates a new Net::Hotline::Task object with all attributes set to undef. With three or four arguments (PATH is optional), creates a new Net::Hotline::Task object with task number NUM, task type TYPE, start time START, user socket number SOCKET, and file path PATH. =back =head1 METHODS All the Net::Hotline::Task methods are simple attribute get/set routines. If given an argument, they set an attribute. In all cases, they return the current value of the attribute. =over 4 =item error EXPR The error state of the task. A true value means there was an error. =item error_text TEXT The error message text. This only applies if error() returns a true value. =item finish TIME The time (in platform-native time format, i.e. seconds since the epoch on a Unix system) that a task completed. =item num NUMBER The unique task number. Task numbers increase sequentially. =item path PATH The path information associated with a task (if any). In situations where two paths may be associated with a task (a "move file" task, for example), a reference to an array containing the paths will be returned. =item socket NUMBER The unique user socket number associated with a task (if any). =item start TIME The time (in platform-native time format) that a task was started. =item type TASK_TYPE The HTLC_TASK_XXX constant specifying the type of task. These constants are defined in Net::Hotline::Constants, and include: HTLC_TASK_KICK Disconnect a user. HTLC_TASK_LOGIN Log into server. HTLC_TASK_NEWS Get the news. HTLC_TASK_NEWS_POST Post to news. HTLC_TASK_FILE_DELETE Delete a file. HTLC_TASK_FILE_INFO Get file information. HTLC_TASK_FILE_LIST Get a file list. HTLC_TASK_FILE_MKDIR Create a new folder. HTLC_TASK_FILE_MOVE Move a file. HTLC_TASK_SEND_MSG Send a private message. HTLC_TASK_SET_INFO Set file information. HTLC_TASK_USER_INFO Get user information. HTLC_TASK_USER_LIST Get the userlist. =back =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Hotline-0.83/lib/Net/Hotline/FileListItem.pod010064400427010022003000000027770757122347300227360ustar00macintshalumni00000400000004=head1 NAME Net::Hotline::FileListItem - File object used internally by Net::Hotline::Client =head1 SYNOPSIS use Net::Hotline::FileListItem; $file = new Net::Hotline::FileListItem; $file->name("foo.txt"); $file->type("TEXT"); ... =head1 DESCRIPTION Net::Hotline::FileListItem is a simple class for storing and retrieving file information, You should never have to create your own Net::Hotline::FileListItem objects when using Net::Hotline::Client. Getting and (to a lesser extent) setting attributes is all that should be necessary. =head1 CONSTRUCTION =over 4 =item new Creates a new Net::Hotline::FileListItem object with all attributes set to undef (or zero for numeric attributes). =back =head1 METHODS All the Net::Hotline::FileListItem methods are simple attribute get/set routines. If given an argument, they set an attribute. In all cases, they return the current value of the attribute. =over 4 =item creator TEXT The file creator, given as a four-letter Mac OS creator code ("TTXT", "SIT!", etc.) =item name TEXT The file name. =item size NUM The size of the file in bytes. =item type TEXT The file type, given as a four-letter Mac OS type code ("TEXT", "PICT", etc.) or Net::Hotline::Constants::HTLC_FOLDER_TYPE for folders. =back =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Hotline-0.83/lib/Net/Hotline/FileListItem.pm010064400427010022003000000023170757122347200225550ustar00macintshalumni00000400000004package Net::Hotline::FileListItem; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); $VERSION = '0.80'; sub new { my($class, $data) = @_; my($self); if(defined($data)) { my($name_len) = unpack("L", substr($data, 16, 4)); $self = { 'TYPE' => substr($data, 0, 4), 'CREATOR' => substr($data, 4, 4), 'SIZE' => unpack("N", substr($data, 8, 4)), 'UNKNOWN' => substr($data, 12, 4), 'NAME' => substr($data, 20, $name_len) }; } else { $self = { 'TYPE' => undef, 'CREATOR' => undef, 'SIZE' => 0x00000000, 'UNKNOWN' => 0x00000000, 'NAME' => undef }; } bless $self, $class; return $self; } sub type { $_[0]->{'TYPE'} = $_[1] if(@_ == 2); return $_[0]->{'TYPE'}; } sub creator { $_[0]->{'CREATOR'} = $_[1] if(@_ == 2); return $_[0]->{'CREATOR'}; } sub size { $_[0]->{'SIZE'} = $_[1] if(@_ == 2); return $_[0]->{'SIZE'}; } sub name { $_[0]->{'NAME'} = $_[1] if(@_ == 2); return $_[0]->{'NAME'}; } 1; Net-Hotline-0.83/lib/Net/Hotline/User.pm010064400427010022003000000034110757122347400211370ustar00macintshalumni00000400000004package Net::Hotline::User; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); $VERSION = '0.80'; sub new { my($class, @args) = @_; my($data) = join('', @args); my($self); if(@args == 5) { $self = { 'SOCKET' => $args[0], 'NICK' => $args[1], 'LOGIN' => $args[2], 'ICON' => $args[3], 'COLOR' => $args[4], 'INFO' => undef }; } elsif(@args == 1) { my($nick_len) = unpack("n", substr($data, 6, 2)); $self = { 'SOCKET' => unpack("n", substr($data, 0, 2)), 'ICON' => unpack("n", substr($data, 2, 2)), 'COLOR' => unpack("n", substr($data, 4, 2)), 'NICK' => join('', substr($data, 8, $nick_len)), 'LOGIN' => undef, 'INFO' => undef }; } else { $self = { 'SOCKET' => undef, 'NICK' => undef, 'LOGIN' => undef, 'ICON' => undef, 'COLOR' => undef, 'INFO' => undef }; } bless $self, $class; return $self; } sub socket { $_[0]->{'SOCKET'} = $_[1] if(@_ > 1 && $_[1] =~ /^\d+$/); return $_[0]->{'SOCKET'}; } sub nick { $_[0]->{'NICK'} = $_[1] if(defined($_[1])); return $_[0]->{'NICK'}; } sub login { $_[0]->{'LOGIN'} = $_[1] if(defined($_[1])); return $_[0]->{'LOGIN'}; } sub icon { $_[0]->{'ICON'} = $_[1] if(@_ > 1 && $_[1] =~ /^-?\d+$/); return $_[0]->{'ICON'}; } sub color { $_[0]->{'COLOR'} = $_[1] if(@_ > 1 && $_[1] =~ /^\d+$/); return $_[0]->{'COLOR'}; } sub info { $_[0]->{'INFO'} = $_[1] if(defined($_[1])); return $_[0]->{'INFO'}; } 1; Net-Hotline-0.83/lib/Net/Hotline/FileInfoItem.pod010064400427010022003000000044340757122347200227050ustar00macintshalumni00000400000004=head1 NAME Net::Hotline::FileInfoItem - File object used internally by Net::Hotline::Client =head1 SYNOPSIS use Net::Hotline::FileInfoItem; $file = new Net::Hotline::FileInfoItem; $file->name("smile"); $file->comments("A happy file."); ... =head1 DESCRIPTION Net::Hotline::FileInfoItem is a simple class for storing and retrieving file information, You should never have to create your own Net::Hotline::FileInfoItem objects when using Net::Hotline::Client. Getting and (to a lesser extent) setting attributes is all that should be necessary. =head1 CONSTRUCTION =over 4 =item new Creates a new Net::Hotline::FileInfoItem object with all attributes set to undef. =back =head1 METHODS All the Net::Hotline::FileInfoItem methods are simple attribute get/set routines. If given an argument, they set an attribute. In all cases, they return the current value of the attribute. =over 4 =item comment TEXT The file comments (as seen in the Mac OS Finder). =item ctime NUM The creation time of the file, given as a Mac OS native time value. Add the constant Net::Hotline::Constants::HTLC_MACOS_TO_UNIX_TIME to it to change it to seconds since the Unix epoch. =item creator TEXT The file creator, given as a four-letter Mac OS creator code ("TTXT", "SIT!", etc.) =item name TEXT The file name. =item icon The file icon given as a four-letter code. =item mtime NUM The modification time of the file, given as a Mac OS native time value. Add the constant Net::Hotline::Constants::HTLC_MACOS_TO_UNIX_TIME to it to change it to seconds since the Unix epoch. =item ctime NUM The creation time of the file, given as a Mac OS native time value. Add the constant Net::Hotline::Constants::HTLC_MACOS_TO_UNIX_TIME to it to change it to seconds since the Unix epoch. =item size NUM The size of the file in bytes. =item type TEXT The file type, given as a four-letter Mac OS type code ("TEXT", "PICT", etc.), Net::Hotline::Constants::HTLC_INFO_FOLDER_TYPE for folders, and Net::Hotline::Constants::HTLC_INFO_FALIAS_TYPE for folder aliases. =back =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Hotline-0.83/lib/Net/Hotline/Shared.pm010064400427010022003000000063310757122347300214320ustar00macintshalumni00000400000004package Net::Hotline::Shared; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use Carp; use IO::Handle; use POSIX qw(F_GETFL F_SETFL O_NONBLOCK EINTR EWOULDBLOCK EAGAIN); use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $VERSION); require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(_encode _write _read _hexdump _debug _set_blocking); %EXPORT_TAGS = (all => \@EXPORT_OK); $VERSION = '0.80'; sub _debug { if($Net::Hotline::Client::DEBUG) { print STDERR join('', @_); } } sub _encode { my($data) = join('', @_); my($i, $len, $enc); $len = length($data); $enc = ''; for($i = 0; $i < $len; $i++) { $enc .= pack("C", (255 - unpack("C", substr($data, $i, 1)))); } return $enc; } sub _write { my($fh, $data_ref, $length) = @_; my($written, $offset); $offset = 0; while($length > 0) # Handle partial writes { $written = syswrite($fh, $$data_ref, $length, $offset); next if($! == EINTR); unless(defined($written)) { next if($! == EWOULDBLOCK || $! == EAGAIN); croak("System write error(", $! + 0, "): $!\n"); } $length -= $written; $offset += $written; } return $offset; } sub _read { my($fh, $data_ref, $length, $blocking) = @_; my($offset) = 0; my($read) = 0; $blocking = 1 unless(defined($blocking)); #_debug("Reading $length..."); while($length > 0) # Handle partial reads { $read = sysread($fh, $$data_ref, $length, $offset); unless(defined($read)) { next if($! == EINTR); # Once we read a little bit, we keep readinuntil we get it all # Otherwise, we can return undef and treat it as a WOULDBLOCK if($blocking || $offset > 0) { next } else { return } } $offset += $read; $length -= $read; } #_debug("read $offset ($length)\n"); return($offset); } sub _set_blocking { my($fh, $blocking) = @_; if($IO::VERSION >= 1.19) # The easy way, with the IO module { $fh->blocking($blocking); } else # The hard way...not 100% successful :-/ { my($flags) = fcntl($fh, F_GETFL, 0); defined($flags) || croak "Can't get flags for socket: $!\n"; if($blocking) { fcntl($fh, F_SETFL, $flags & ~O_NONBLOCK) || croak "Can't make socket blocking: $!\n"; } else { fcntl($fh, F_SETFL, $flags | O_NONBLOCK) || croak "Can't make socket nonblocking: $!\n"; } } } sub _hexdump { my($data) = join('', @_); my($ret, $hex, $ascii, $len, $i); $len = length($data); for($i = 0; $i < $len; $i++) { if($i > 0) { if($i % 4 == 0) { $hex .= ' '; } if($i % 16 == 0) { $ret .= "$hex$ascii\n"; $ascii = $hex = ''; } } $hex .= sprintf("%02x ", ord(substr($data, $i, 1))); $ascii .= sprintf("%c", (ord(substr($data, $i, 1)) > 31 and ord(substr($data, $i, 1)) < 127) ? ord(substr($data, $i, 1)) : 46); } if(length($hex) < 50) { $hex .= ' ' x (50 - length($hex)); } $ret .= "$hex $ascii\n"; return $ret; } 1; Net-Hotline-0.83/lib/Net/Hotline/TrackerListItem.pod010064400427010022003000000033270757122347400234430ustar00macintshalumni00000400000004=head1 NAME Net::Hotline::TrackerListItem - File object used internally by Net::Hotline::Client =head1 SYNOPSIS use Net::Hotline::TrackerListItem; $file = new Net::Hotline::TrackerListItem; $file->address("hotline.foo.com"); $file->port(5500); ... =head1 DESCRIPTION Net::Hotline::TrackerListItem is a simple class for storing and retrieving tracked server information, You should never have to create your own Net::Hotline::TrackerListItem objects when using Net::Hotline::Client. Getting and (to a lesser extent) setting attributes is all that should be necessary. =head1 CONSTRUCTION =over 4 =item new ADDRESS, PORT, NUM_USERS, NAME, DESCRIPTION With exactly five arguments, creates a new Net::Hotline::TrackerListItem object with all attributes set. With no arguments, creates a new Net::Hotline::TrackerListItem object with all attributes set to undef. =back =head1 METHODS All the Net::Hotline::TrackerListItem methods are simple attribute get/set routines. If given an argument, they set an attribute. In all cases, they return the current value of the attribute. =over 4 =item address TEXT The IP address of the server. =item port NUM The port the server is running on. =item num_users NUM The (claimed) number of users connected to the server. =item name TEXT The server name, as set by the server administrator (i.e. "Ambrosia Software" or "Myth Central") =item description TEXT The server description, as set by the server administrator. =back =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Hotline-0.83/lib/Net/Hotline/Protocol/004070000427010022003000000000000757122352700214555ustar00macintshalumni00000400000004Net-Hotline-0.83/lib/Net/Hotline/Protocol/Header.pm010064400427010022003000000026250757122347500232210ustar00macintshalumni00000400000004package Net::Hotline::Protocol::Header; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); $VERSION = '0.80'; sub new { my($class, $data) = @_; my($self); if(defined($data)) { $self = { 'TYPE' => substr($data, 0, 4), 'SEQ' => substr($data, 4, 4), 'TASK' => substr($data, 8, 4), 'LEN' => substr($data, 12, 4), 'LEN2' => substr($data, 16, 4) }; } else { $self = { 'TYPE' => 0x00000000, 'SEQ' => 0x00000000, 'TASK' => 0x00000000, 'LEN' => 0x00000000, 'LEN2' => 0x00000000 }; } bless $self, $class; return $self; } sub type { $_[0]->{'TYPE'} = $_[1] if(defined($_[1])); return $_[0]->{'TYPE'}; } sub seq { $_[0]->{'SEQ'} = $_[1] if(defined($_[1])); return $_[0]->{'SEQ'}; } sub task { $_[0]->{'TASK'} = $_[1] if(defined($_[1])); return $_[0]->{'TASK'}; } sub len { $_[0]->{'LEN'} = $_[1] if(defined($_[1])); return $_[0]->{'LEN'}; } sub len2 { $_[0]->{'LEN2'} = $_[1] if(defined($_[1])); return $_[0]->{'LEN2'}; } sub header { return pack("N5", $_[0]->{'TYPE'}, $_[0]->{'SEQ'}, $_[0]->{'TASK'}, $_[0]->{'LEN'}, $_[0]->{'LEN2'}); } 1; Net-Hotline-0.83/lib/Net/Hotline/Protocol/Packet.pm010064400427010022003000000265030757122347600232420ustar00macintshalumni00000400000004package Net::Hotline::Protocol::Packet; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); use Carp; use POSIX qw(:errno_h); use Net::Hotline::User; use Net::Hotline::FileListItem; use Net::Hotline::Protocol::Header; use Net::Hotline::Shared qw(:all); use Net::Hotline::Constants qw(HTLC_DATA_PCHAT_SUBJECT HTLC_DATA_RFLT HTLC_EWOULDBLOCK HTLC_NEWLINE HTLS_DATA_AGREEMENT HTLS_DATA_CHAT HTLS_DATA_COLOR HTLS_DATA_FILE_COMMENT HTLS_DATA_FILE_CREATOR HTLS_DATA_FILE_CTIME HTLS_DATA_FILE_ICON HTLS_DATA_FILE_LIST HTLS_DATA_FILE_MTIME HTLS_DATA_FILE_NAME HTLS_DATA_FILE_SIZE HTLS_DATA_FILE_TYPE HTLS_DATA_HTXF_REF HTLS_DATA_HTXF_SIZE HTLS_DATA_ICON HTLS_DATA_MSG HTLS_DATA_NEWS HTLS_DATA_NEWS_POST HTLS_DATA_NICKNAME HTLS_DATA_PCHAT_REF HTLS_DATA_SERVER_MSG HTLS_DATA_SOCKET HTLS_DATA_TASK_ERROR HTLS_DATA_USER_INFO HTLS_DATA_USER_LIST HTLS_HDR_TASK SIZEOF_HL_PROTO_HDR HTLS_DATA_REPLY HTLS_DATA_IS_REPLY); $VERSION = '0.80'; sub new { my($class) = shift; my($self); $self = { 'PROTO_HEADER' => undef, 'USER_LIST' => undef, 'FILE_LIST' => undef, 'USER_INFO' => undef, 'NEWS' => undef, 'SOCKET' => undef, 'ICON' => undef, 'COLOR' => undef, 'NICK' => undef, 'TASK_ERROR' => undef, 'DATA' => undef, 'FILE_ICON' => undef, 'FILE_TYPE' => undef, 'FILE_CREATOR' => undef, 'FILE_SIZE' => undef, 'FILE_NAME' => undef, 'FILE_COMMENT' => undef, 'FILE_CTIME' => undef, 'FILE_MTIME' => undef, 'HTXF_SIZE' => undef, 'HTXF_REF' => undef, 'HTXF_RFLT' => undef, 'PCHAT_REF' => undef, 'IS_REPLY' => undef, 'REPLY_TO' => undef, 'TYPE' => undef }; bless $self, $class; return $self; } sub clear { my($self) = shift; $self->{'PROTO_HEADER'} = $self->{'USER_LIST'} = $self->{'FILE_LIST'} = $self->{'USER_INFO'} = $self->{'NEWS'} = $self->{'SOCKET'} = $self->{'ICON'} = $self->{'COLOR'} = $self->{'NICK'} = $self->{'TASK_ERROR'} = $self->{'DATA'} = $self->{'FILE_ICON'} = $self->{'FILE_TYPE'} = $self->{'FILE_CREATOR'} = $self->{'FILE_SIZE'} = $self->{'FILE_NAME'} = $self->{'FILE_COMMENT'} = $self->{'FILE_CTIME'} = $self->{'FILE_MTIME'} = $self->{'HTXF_SIZE'} = $self->{'HTXF_REF'} = $self->{'HTXF_RFLT'} = $self->{'PCHAT_REF'} = $self->{'IS_REPLY'} = $self->{'REPLY_TO'} = $self->{'TYPE'} = undef; } sub read_parse { my($self, $fh, $blocking) = @_; my($data, $length, $atom_count, $atom_type, $atom_len, $read_err, $nick, $socket, $icon, $user_type, $name, $color, $read); $self->clear(); unless($fh->opened()) { $self->{'TYPE'} = 'DISCONNECTED'; return(1); } $read = _read($fh, \$data, SIZEOF_HL_PROTO_HDR, $blocking); $read_err = 0 + $!; # Get the numerical value of the magical $! unless(defined($read) && $read > 0) { if($read_err == EWOULDBLOCK || $read_err == EAGAIN) { #_debug("WOULDBLOCK\n"); return(HTLC_EWOULDBLOCK); } elsif($read_err == ECONNRESET || $read_err == ECONNABORTED || $read_err == ENOTCONN) { #_debug("DISCONNECTED\n"); $self->clear(); $self->{'TYPE'} = 'DISCONNECTED'; return(1); } else { # I'm assuming this is a MacPerl bug: sysread() sometimes returns # undefined without setting $!. I use the "shrug and continue" # method here and just treat it as an idle event. return(HTLC_EWOULDBLOCK) if($^O eq 'MacOS'); # It's fatal on non-Mac OS systems, however. die "sysread() error($read_err): $!\n"; # I'm also getting: # # sysread() error(145): Connection timed out # # On Solaris. Hmmmm... } } _debug("Packet data:\n", _hexdump($data)); $self->{'PROTO_HEADER'} = new Net::Hotline::Protocol::Header($data); $length = unpack("N", $self->{'PROTO_HEADER'}->len()); $self->{'TYPE'} = unpack("N", $self->{'PROTO_HEADER'}->type()); if($self->{'TYPE'} == HTLS_HDR_TASK) { $self->{'TASK_NUM'} = unpack("N", $self->{'PROTO_HEADER'}->seq()); } $length -= _read($fh, \$atom_count, 2); $atom_count = unpack("n", $atom_count); _debug("Atom count: $atom_count\n"); for(; $atom_count != 0; $atom_count--) { # This probably doesn't need to be here anymore, but just to be safe... if($length < 4) { $length -= _read($fh, \$data, $length); _debug("Slurped up < 4 bytes, length = $length\n"); return(1); } $length -= _read($fh, \$atom_type, 2); $length -= _read($fh, \$atom_len, 2); _debug("Atom type:\n", _hexdump($atom_type)); _debug("Atom length:\n", _hexdump($atom_len)); $atom_type = unpack("n", $atom_type); $atom_len = unpack("n", $atom_len); if($atom_type == HTLS_DATA_USER_LIST) { my($user_data, $user); $length -= _read($fh, \$user_data, $atom_len); $user = new Net::Hotline::User($user_data); _debug(" Nick: ", $user->nick(), "\n", " Icon: ", $user->icon(), "\n", "Socket: ", $user->socket(), "\n", " Color: ", $user->color(), "\n"); $self->{'USER_LIST'}->{$user->socket()} = $user; } elsif($atom_type == HTLS_DATA_FILE_LIST) { my($file_data, $file); $length -= _read($fh, \$file_data, $atom_len); $file = new Net::Hotline::FileListItem($file_data); _debug(" Type: ", $file->type(), "\n", "Creator: ", $file->creator(), "\n", " Size: ", $file->size(), "\n", " Name: ", $file->name(), "\n"); push(@{$self->{'FILE_LIST'}}, $file); } elsif($atom_type == HTLS_DATA_SOCKET) { $length -= _read($fh, \$socket, $atom_len); _debug("Socket: ", _hexdump($socket)); # Older versions of the Hotline server sent socket numbers # in 4 bytes. Newer versions send it in 2. Nice. if($atom_len == 4) { $self->{'SOCKET'} = unpack("N", $socket); } else { $self->{'SOCKET'} = unpack("n", $socket); } } elsif($atom_type == HTLS_DATA_ICON) { $length -= _read($fh, \$icon, $atom_len); _debug("Icon: ", _hexdump($icon)); $self->{'ICON'} = unpack("n", $icon); } elsif($atom_type == HTLS_DATA_COLOR) { $length -= _read($fh, \$color, $atom_len); _debug("Color: ", _hexdump($color)); $self->{'COLOR'} = unpack("n", $color); } elsif($atom_type == HTLS_DATA_NICKNAME) { $length -= _read($fh, \$nick, $atom_len); _debug("Nick: ", _hexdump($nick)); $self->{'NICK'} = $nick; } elsif($atom_type == HTLS_DATA_TASK_ERROR) { $length -= _read($fh, \$data, $atom_len); _debug("Task error:\n", _hexdump($data)); $data =~ s/@{[HTLC_NEWLINE]}/\n/osg; $self->{'TASK_ERROR'} = $data; } elsif($atom_type == HTLS_DATA_FILE_ICON) { $length -= _read($fh, \$data, $atom_len); _debug("File icon:\n", _hexdump($data)); $self->{'FILE_ICON'} = unpack("n", $data); } elsif($atom_type == HTLS_DATA_FILE_TYPE) { $length -= _read($fh, \$data, $atom_len); _debug("File type:\n", _hexdump($data)); $self->{'FILE_TYPE'} = $data; } elsif($atom_type == HTLS_DATA_FILE_CREATOR) { $length -= _read($fh, \$data, $atom_len); _debug("File creator:\n", _hexdump($data)); $self->{'FILE_CREATOR'} = $data; } elsif($atom_type == HTLS_DATA_FILE_SIZE) { $length -= _read($fh, \$data, $atom_len); _debug("File size:\n", _hexdump($data)); if($atom_len == 2) # Grrrrrrr... { $self->{'FILE_SIZE'} = unpack("n", $data); } else { $self->{'FILE_SIZE'} = unpack("N", $data); } } elsif($atom_type == HTLS_DATA_FILE_NAME) { $length -= _read($fh, \$data, $atom_len); _debug("File name:\n", _hexdump($data)); $self->{'FILE_NAME'} = $data; } elsif($atom_type == HTLS_DATA_FILE_COMMENT) { $length -= _read($fh, \$data, $atom_len); _debug("File comment:\n", _hexdump($data)); $self->{'FILE_COMMENT'} = $data; } elsif($atom_type == HTLS_DATA_FILE_CTIME) { $length -= _read($fh, \$data, $atom_len); $data =~ s/^....//; _debug("File ctime:\n", _hexdump($data)); $self->{'FILE_CTIME'} = unpack("N", $data); } elsif($atom_type == HTLS_DATA_FILE_MTIME) { $length -= _read($fh, \$data, $atom_len); $data =~ s/^....//; _debug("File mtime:\n", _hexdump($data)); $self->{'FILE_MTIME'} = unpack("N", $data); } elsif($atom_type == HTLS_DATA_PCHAT_REF) { $length -= _read($fh, \$data, $atom_len); _debug("Private chat ref: ", _hexdump($data)); # Server 1.2.1 gives chat refs in 2 bytes. Annoying! if($atom_len == 2) { $self->{'PCHAT_REF'} = unpack("n", $data); } else { $self->{'PCHAT_REF'} = unpack("N", $data); } } elsif($atom_type == HTLS_DATA_IS_REPLY) { $length -= _read($fh, \$data, $atom_len); _debug("Is reply:\n", _hexdump($data)); $self->{'IS_REPLY'} = unpack("n", $data); } elsif($atom_type == HTLS_DATA_REPLY) { $length -= _read($fh, \$data, $atom_len); _debug("In reply to:\n", _hexdump($data)); $data =~ s/@{[HTLC_NEWLINE]}/\n/osg; $self->{'REPLY_TO'} = $data; } elsif($atom_type == HTLS_DATA_MSG || $atom_type == HTLS_DATA_NEWS || $atom_type == HTLS_DATA_AGREEMENT || $atom_type == HTLS_DATA_USER_INFO || $atom_type == HTLS_DATA_CHAT || $atom_type == HTLC_DATA_PCHAT_SUBJECT || $atom_type == HTLS_DATA_MSG || $atom_type == HTLS_DATA_SERVER_MSG || $atom_type == HTLS_DATA_NEWS_POST) { $length -= _read($fh, \$data, $atom_len); _debug("Data:\n", _hexdump($data)); $data =~ s/@{[HTLC_NEWLINE]}/\n/osg; $self->{'DATA'} = $data; } elsif($atom_type == HTLS_DATA_HTXF_SIZE) { $length -= _read($fh, \$data, $atom_len); _debug("HTXF size:\n", _hexdump($data)); if($atom_len == 2) { $self->{'HTXF_SIZE'} = unpack("n", $data); } else { $self->{'HTXF_SIZE'} = unpack("N", $data); } } elsif($atom_type == HTLS_DATA_HTXF_REF) { $length -= _read($fh, \$data, $atom_len); _debug("HTXF ref:\n", _hexdump($data)); $self->{'HTXF_REF'} = unpack("N", $data); } elsif($atom_type == HTLC_DATA_RFLT) { $length -= _read($fh, \$data, $atom_len); _debug("HTXF RFLT:\n", _hexdump($data)); $self->{'HTXF_RFLT'} = $data; } else { $length -= _read($fh, \$data, $atom_len); _debug("Default data:\n", _hexdump($data)); $self->{'DATA'} = $data; } } if($length > 0) # Should not be reached... { _debug("Left-over length!\n"); while($length > 0) { $length -= _read($fh, \$data, $length); _debug("Left over data:\n", _hexdump($data)); } } return(1); } 1; Net-Hotline-0.83/lib/Net/Hotline/Client.pm010064400427010022003000003626050757122346500214540ustar00macintshalumni00000400000004package Net::Hotline::Client; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw(@ISA $VERSION $DEBUG); use Carp; use IO::File; use IO::Socket; use Net::Hotline::User; use Net::Hotline::Task; use Net::Hotline::PrivateChat; use Net::Hotline::FileListItem; use Net::Hotline::FileInfoItem; use Net::Hotline::TrackerListItem; use Net::Hotline::Protocol::Packet; use Net::Hotline::Protocol::Header; use Net::Hotline::Shared qw(:all); use Net::Hotline::Constants qw(:all); if($^O eq 'MacOS') # "#ifdef", where have you gone... { require Mac::MoreFiles; require Mac::Files; } use AutoLoader 'AUTOLOAD'; # # Class attributes # $VERSION = '0.83'; $DEBUG = 0; # CRC perl code lifted from Convert::BinHex by Eryq (eryq@enteract.com) # An array useful for CRC calculations that use 0x1021 as the "seed": my(@CRC_MAGIC) = ( 0x0000, 0x1021, 0x2042, 0x3063, 0x4084, 0x50A5, 0x60C6, 0x70E7, 0x8108, 0x9129, 0xA14A, 0xB16B, 0xC18C, 0xD1AD, 0xE1CE, 0xF1EF, 0x1231, 0x0210, 0x3273, 0x2252, 0x52B5, 0x4294, 0x72F7, 0x62D6, 0x9339, 0x8318, 0xB37B, 0xA35A, 0xD3BD, 0xC39C, 0xF3FF, 0xE3DE, 0x2462, 0x3443, 0x0420, 0x1401, 0x64E6, 0x74C7, 0x44A4, 0x5485, 0xA56A, 0xB54B, 0x8528, 0x9509, 0xE5EE, 0xF5CF, 0xC5AC, 0xD58D, 0x3653, 0x2672, 0x1611, 0x0630, 0x76D7, 0x66F6, 0x5695, 0x46B4, 0xB75B, 0xA77A, 0x9719, 0x8738, 0xF7DF, 0xE7FE, 0xD79D, 0xC7BC, 0x48C4, 0x58E5, 0x6886, 0x78A7, 0x0840, 0x1861, 0x2802, 0x3823, 0xC9CC, 0xD9ED, 0xE98E, 0xF9AF, 0x8948, 0x9969, 0xA90A, 0xB92B, 0x5AF5, 0x4AD4, 0x7AB7, 0x6A96, 0x1A71, 0x0A50, 0x3A33, 0x2A12, 0xDBFD, 0xCBDC, 0xFBBF, 0xEB9E, 0x9B79, 0x8B58, 0xBB3B, 0xAB1A, 0x6CA6, 0x7C87, 0x4CE4, 0x5CC5, 0x2C22, 0x3C03, 0x0C60, 0x1C41, 0xEDAE, 0xFD8F, 0xCDEC, 0xDDCD, 0xAD2A, 0xBD0B, 0x8D68, 0x9D49, 0x7E97, 0x6EB6, 0x5ED5, 0x4EF4, 0x3E13, 0x2E32, 0x1E51, 0x0E70, 0xFF9F, 0xEFBE, 0xDFDD, 0xCFFC, 0xBF1B, 0xAF3A, 0x9F59, 0x8F78, 0x9188, 0x81A9, 0xB1CA, 0xA1EB, 0xD10C, 0xC12D, 0xF14E, 0xE16F, 0x1080, 0x00A1, 0x30C2, 0x20E3, 0x5004, 0x4025, 0x7046, 0x6067, 0x83B9, 0x9398, 0xA3FB, 0xB3DA, 0xC33D, 0xD31C, 0xE37F, 0xF35E, 0x02B1, 0x1290, 0x22F3, 0x32D2, 0x4235, 0x5214, 0x6277, 0x7256, 0xB5EA, 0xA5CB, 0x95A8, 0x8589, 0xF56E, 0xE54F, 0xD52C, 0xC50D, 0x34E2, 0x24C3, 0x14A0, 0x0481, 0x7466, 0x6447, 0x5424, 0x4405, 0xA7DB, 0xB7FA, 0x8799, 0x97B8, 0xE75F, 0xF77E, 0xC71D, 0xD73C, 0x26D3, 0x36F2, 0x0691, 0x16B0, 0x6657, 0x7676, 0x4615, 0x5634, 0xD94C, 0xC96D, 0xF90E, 0xE92F, 0x99C8, 0x89E9, 0xB98A, 0xA9AB, 0x5844, 0x4865, 0x7806, 0x6827, 0x18C0, 0x08E1, 0x3882, 0x28A3, 0xCB7D, 0xDB5C, 0xEB3F, 0xFB1E, 0x8BF9, 0x9BD8, 0xABBB, 0xBB9A, 0x4A75, 0x5A54, 0x6A37, 0x7A16, 0x0AF1, 0x1AD0, 0x2AB3, 0x3A92, 0xFD2E, 0xED0F, 0xDD6C, 0xCD4D, 0xBDAA, 0xAD8B, 0x9DE8, 0x8DC9, 0x7C26, 0x6C07, 0x5C64, 0x4C45, 0x3CA2, 0x2C83, 0x1CE0, 0x0CC1, 0xEF1F, 0xFF3E, 0xCF5D, 0xDF7C, 0xAF9B, 0xBFBA, 0x8FD9, 0x9FF8, 0x6E17, 0x7E36, 0x4E55, 0x5E74, 0x2E93, 0x3EB2, 0x0ED1, 0x1EF0 ); 1; # # Non-autoloaded object methods # sub new { my($class) = shift; my($self) = { 'NICK' => undef, 'LOGIN' => undef, 'COLOR' => undef, 'SERVER_PORT' => undef, 'SERVER_ADDR' => undef, 'TRACKER_ADDR' => undef, 'SOCKET' => undef, 'BLOCKING' => 1, 'SERVER' => undef, 'SEQNUM' => 1, 'USER_LIST' => undef, 'NEWS' => undef, 'FILES' => undef, 'AGREEMENT' => undef, 'PCHATS' => undef, 'TASKS' => undef, 'FILE_INFO' => undef, 'HANDLERS' => { 'AGREEMENT' => undef, 'BAN' => undef, 'CHAT' => undef, 'CHAT_ACTION' => undef, 'COLOR' => undef, 'EVENT' => undef, 'FILE_DELETE' => undef, 'FILE_GET' => undef, 'FILE_GET_INFO' => undef, 'FILE_LIST' => undef, 'FILE_MKDIR' => undef, 'FILE_MOVE' => undef, 'FILE_SET_INFO' => undef, 'ICON' => undef, 'JOIN' => undef, 'KICK' => undef, 'LEAVE' => undef, 'LOGIN' => undef, 'MSG' => undef, 'NEWS' => undef, 'NEWS_POST' => undef, 'NEWS_POSTED' => undef, 'NICK' => undef, 'PCHAT_ACCEPT' => undef, 'PCHAT_CREATE' => undef, 'PCHAT_INVITE' => undef, 'PCHAT_JOIN' => undef, 'PCHAT_LEAVE' => undef, 'PCHAT_SUBJECT' => undef, 'QUIT' => undef, 'SEND_MSG' => undef, 'SERVER_MSG' => undef, 'TASK_ERROR' => undef, 'USER_GETINFO' => undef, 'USER_LIST' => undef }, 'BLOCKING_TASKS' => undef, 'DEFAULT_HANDLERS' => undef, 'HANDLERS_WHEN_BLOCKING' => undef, 'LOGGED_IN' => undef, 'EVENT_TIMING' => 1, 'CONNECT_TIMEOUT' => 15, 'PATH_SEPARATOR' => HTLC_PATH_SEPARATOR, 'HTXF_BUFSIZE' => HTXF_BUFSIZE, 'DOWNLOADS_DIR' => undef, 'DATA_FORK_EXT' => '.data', 'RSRC_FORK_EXT' => '.rsrc', 'LAST_ACTIVITY' => time(), 'LAST_ERROR' => undef, 'MACOS' => ($^O eq 'MacOS') ? 1 : 0 }; bless $self, $class; return $self; } sub agreement { $_[0]->{'AGREEMENT'} } sub blocking { my($self, $blocking) = @_; return $self->{'BLOCKING'} unless(@_ == 2); if(ref($self->{'SERVER'}) && $self->{'SERVER'}->opened()) { _set_blocking($self->{'SERVER'}, $blocking); } $self->{'BLOCKING'} = (($blocking) ? 1 : 0); return $self->{'BLOCKING'}; } sub blocking_tasks { my($self, $arg) = @_; $self->{'BLOCKING_TASKS'} = ($arg) ? 1 : 0 if(@_ == 2); return $self->{'BLOCKING_TASKS'}; } sub connect_timeout { my($self, $secs) = @_; $self->{'CONNECT_TIMEOUT'} = $secs if($secs =~ /^\d+$/); return $self->{'CONNECT_TIMEOUT'}; } sub default_handlers { my($self, $arg) = @_; $self->{'DEFAULT_HANDLERS'} = ($arg) ? 1 : 0 if(@_ == 2); return $self->{'DEFAULT_HANDLERS'}; } sub downloads_dir { my($self, $dir) = @_; $self->{'DOWNLOADS_DIR'} = $dir if(-d $dir); return $self->{'DOWNLOADS_DIR'}; } sub data_fork_extension { my($self, $ext) = @_; croak("The data fork extension may not be the same as the resource fork extension!") if($ext eq $self->{'DATA_FORK_EXT'}); $self->{'DATA_FORK_EXT'} = $ext if(defined($ext)); return $self->{'DATA_FORK_EXT'}; } sub event_timing { my($self, $secs) = @_; if(defined($secs)) { croak qw(Bad argument to event_timing() - "$secs") if($secs =~ /[^0-9.]/); $self->{'EVENT_TIMING'} = $secs; } return $self->{'EVENT_TIMING'}; } sub files { $_[0]->{'FILES'} } sub handlers { $_[0]->{'HANDLERS'} } sub handlers_during_blocking_tasks { my($self, $arg) = @_; $self->{'HANDLERS_WHEN_BLOCKING'} = ($arg) ? 1 : 0 if(@_ == 2); return $self->{'HANDLERS_WHEN_BLOCKING'}; } sub last_error { $_[0]->{'LAST_ERROR'} } sub clear_error { $_[0]->{'LAST_ERROR'} = undef } sub xfer_bufsize { my($self, $size) = @_; $self->{'HTXF_BUFSIZE'} = $size if($size =~ /^\d+$/); return $self->{'HTXF_BUFSIZE'}; } sub last_activity { my($self) = shift; return $self->{'LAST_ACTIVITY'}; } sub news { $_[0]->{'NEWS'} } sub path_separator { my($self, $separator) = @_; $self->{'PATH_SEPARATOR'} = $separator if($separator =~ /^.$/); return $self->{'PATH_SEPARATOR'}; } sub rsrc_fork_extension { my($self, $ext) = @_; croak("The resource fork extension may not be the same as the data fork extension!") if($ext eq $self->{'RSRC_FORK_EXT'}); $self->{'RSRC_FORK_EXT'} = $ext if(defined($ext)); return $self->{'RSRC_FORK_EXT'}; } sub pchats { $_[0]->{'PCHATS'} } sub userlist { $_[0]->{'USER_LIST'} } sub server { $_[0]->{'SERVER_ADDR'} . ($_[0]->{'SERVER_PORT'} ne HTLS_TCPPORT) ? ":$_[0]->{'SERVER_PORT'}" : ''; } sub connect { my($self, $server) = @_; my($address, $port); if(($address = $server) =~ s/^([^ :]+)(?:[: ](\d+))?$/$1/) { $port = $2 || HTLS_TCPPORT; } else { croak("Bad server address: $server"); } eval { $SIG{'ALRM'} = sub { die "timeout" }; alarm($self->{'CONNECT_TIMEOUT'}); $self->{'SERVER'} = IO::Socket::INET->new(PeerAddr =>$address, PeerPort =>$port, Proto =>'tcp'); alarm(0); $SIG{'ALRM'} = 'DEFAULT'; }; if($@ =~ /timeout/) { $self->{'LAST_ERROR'} = "Timed out after $self->{'CONNECT_TIMEOUT'} seconds"; return; } if(!$self->{'SERVER'} || $@) { $self->{'LAST_ERROR'} = $@ || $! || 'Connection failed'; return; } $self->{'SERVER'}->autoflush(1); $self->{'SERVER_ADDR'} = $address; $self->{'SERVER_PORT'} = $port; return(1); } sub disconnect { my($self) = shift; if(ref($self->{'SERVER'}) && $self->{'SERVER'}->opened()) { $self->{'SERVER'}->close(); $self->{'LOGGED_IN'} = undef; $self->{'SERVER_ADDR'} = undef; return(1); } $self->{'LAST_ERROR'} = 'Not connected.'; return; } sub login { my($self, %args) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_login_now(%args); } else { return $self->_login(%args); } } sub _login_now { my($self, %args) = @_; my($no_news, $no_userlist, $task_num, $task, $packet); $no_news = $args{'NoNews'}; $no_userlist = $args{'NoUserList'}; $args{'NoNews'} = $args{'NoUserList'} = undef; $task_num = $self->_login(%args); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); $self->disconnect(); return; } unless($no_news) { unless($self->get_news()) { $self->{'LAST_ERROR'} = "Login succeeded, but could not get news."; return("0E-0"); } } unless($no_userlist) { unless($self->get_userlist()) { $self->{'LAST_ERROR'} = "Login succeeded, but could not get userlist"; return("0E-0"); } } return(1); } sub _login { my($self, %args) = @_; my($nick, $login, $password, $icon, $enc_login, $enc_password, $proto_header, $data, $response, $task_num, $server); $server = $self->{'SERVER'} or croak "Not connected to a server"; unless($server->opened()) { $self->{'LAST_ERROR'} = "login() called before connect()"; return; } $nick = $args{'Nickname'} || HTLC_DEFAULT_NICK; $login = $args{'Login'} || HTLC_DEFAULT_LOGIN; $icon = $args{'Icon'} || HTLC_DEFAULT_ICON; $password = $args{'Password'}; $self->{'NICK'} = $nick; $self->{'LOGIN'} = $login; $self->{'ICON'} = $icon; _hlc_write($self, $server, \HTLC_MAGIC, HTLC_MAGIC_LEN) || return; _hlc_read($self, $server, \$response, HTLS_MAGIC_LEN) || return; if($response ne HTLS_MAGIC) { $self->{'LAST_ERROR'} = "Handshake failed. Not a hotline server?"; $self->disconnect(); return; } $enc_login = _encode($login); $enc_password = _encode($password); $proto_header = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_LOGIN); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_PROTO_HDR + length($enc_login) + length($enc_password) + length($nick)); $proto_header->len2($proto_header->len); my($fmt) = 'nnna*nna*nna*nnn'; $data = $proto_header->header() . pack($fmt, 0x0004, # Num atoms HTLC_DATA_LOGIN, # Atom type length($enc_login), # Atom length $enc_login, # Atom data HTLC_DATA_PASSWORD, # Atom type length($enc_password), # Atom length $enc_password, # Atom data HTLC_DATA_NICKNAME, # Atom type length($nick), # Atom length $nick, # Atom data HTLC_DATA_ICON, # Atom type 0x0002, # Atom length $icon); # Atom data _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: LOGIN - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_LOGIN, time()); } else { return } unless($args{'NoUserList'}) { $self->req_userlist(); } unless($args{'NoNews'}) { $self->req_news(); } _set_blocking($server, $self->{'BLOCKING'}); return($task_num); } sub run { my($self) = shift; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($ret, $packet); $packet = new Net::Hotline::Protocol::Packet; while($ret = $packet->read_parse($server, $self->{'BLOCKING'})) { _process_packet($self, $packet, $ret) || return(1); } return(1); } sub _process_packet { my($self, $packet, $ret, $blocking_task) = @_; my($data_ref, $type, $use_handlers); $use_handlers = !($blocking_task && !$self->{'HANDLERS_WHEN_BLOCKING'}); $type = $packet->{'TYPE'}; if($ret == HTLC_EWOULDBLOCK) # Idle event { if(defined($self->{'HANDLERS'}->{'EVENT'})) { &{$self->{'HANDLERS'}->{'EVENT'}}($self, 1); } select(undef, undef, undef, $self->{'EVENT_TIMING'}); return(1); } $self->{'LAST_ACTIVITY'} = time(); if(defined($self->{'HANDLERS'}->{'EVENT'})) # Non-idle event { &{$self->{'HANDLERS'}->{'EVENT'}}($self, 0); } _debug("Packet type = $type\n"); if($type == HTLS_HDR_USER_LEAVE) { # Hotline server *BUG* - you may get a "disconnect" packet for a # socket _before_ you get the "connect" packet for that socket! # In fact, the "connect" packet will never arrive in this case. if(defined($packet->{'SOCKET'}) && defined($self->{'USER_LIST'}->{$packet->{'SOCKET'}})) { my($user) = $self->{'USER_LIST'}->{$packet->{'SOCKET'}}; delete $self->{'USER_LIST'}->{$packet->{'SOCKET'}}; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'LEAVE'})) { &{$self->{'HANDLERS'}->{'LEAVE'}}($self, $user); } elsif($self->{'DEFAULT_HANDLERS'}) { print "USER LEFT: ", $user->nick(), "\n"; } } } } elsif($type == HTLS_HDR_TASK) { my($task) = $self->{'TASKS'}->{$packet->{'TASK_NUM'}}; my($task_type) = $task->type(); $task->finish(time()); if(defined($packet->{'TASK_ERROR'})) { $task->error(1); $task->error_text($packet->{'TASK_ERROR'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'TASK_ERROR'})) { &{$self->{'HANDLERS'}->{'TASK_ERROR'}}($self, $task); } else { print "TASK ERROR(", $task->num(), ':', $task->type(), ") ", $task->error_text(), "\n"; } } } else { $task->error(0); if($task_type == HTLC_TASK_USER_LIST && defined($packet->{'USER_LIST'})) { $self->{'USER_LIST'} = $packet->{'USER_LIST'}; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'USER_LIST'})) { &{$self->{'HANDLERS'}->{'USER_LIST'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "GET USER LIST: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_FILE_LIST) { my($path); $task->path("") unless(length($task->path())); $path = $task->path(); if($packet->{'FILE_LIST'}) { $self->{'FILES'}->{$path} = $packet->{'FILE_LIST'}; } else { $self->{'FILES'}->{$path} = []; } if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_LIST'})) { &{$self->{'HANDLERS'}->{'FILE_LIST'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "GET FILE LIST: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_NEWS && defined($packet->{'DATA'})) { my(@news) = split(/_{58}/, $packet->{'DATA'}); $self->{'NEWS'} = \@news; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'NEWS'})) { &{$self->{'HANDLERS'}->{'NEWS'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "GET NEWS: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_USER_INFO && defined($packet->{'DATA'})) { my($user) = $self->{'USER_LIST'}->{$task->socket()}; $user->info($packet->{'DATA'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'USER_GETINFO'})) { &{$self->{'HANDLERS'}->{'USER_GETINFO'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "GET USER INFO: Task complete.\n"; } } _debug("USER_GETINFO for: $packet->{'NICK'} (", $task->socket(), ")\n", $packet->{'DATA'}, "\n"); } elsif($task_type == HTLC_TASK_FILE_INFO) { my($path, $file_info); $task->path("") unless(length($task->path)); $path = $task->path(); $file_info = $self->{'FILE_INFO'} = new Net::Hotline::FileInfoItem(); $file_info->icon($packet->{'FILE_ICON'}); $file_info->type($packet->{'FILE_TYPE'}); $file_info->creator($packet->{'FILE_CREATOR'}); $file_info->size($packet->{'FILE_SIZE'}); $file_info->name($packet->{'FILE_NAME'}); $file_info->comment($packet->{'FILE_COMMENT'}); $file_info->ctime($packet->{'FILE_CTIME'}); $file_info->mtime($packet->{'FILE_MTIME'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_GET_INFO'})) { &{$self->{'HANDLERS'}->{'FILE_GET_INFO'}}($self, $task, $file_info); } elsif($self->{'DEFAULT_HANDLERS'}) { print "FILE_GET_INFO: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_LOGIN) { $self->{'LOGGED_IN'} = 1; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'LOGIN'})) { &{$self->{'HANDLERS'}->{'LOGIN'}}($self); } elsif($self->{'DEFAULT_HANDLERS'}) { print "LOGIN: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_NEWS_POST) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'NEWS_POST'})) { &{$self->{'HANDLERS'}->{'NEWS_POST'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "POST NEWS: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_SEND_MSG) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'SEND_MSG'})) { &{$self->{'HANDLERS'}->{'SEND_MSG'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "SEND MSG: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_KICK) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'KICK'})) { &{$self->{'HANDLERS'}->{'KICK'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "KICK: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_BAN) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'BAN'})) { &{$self->{'HANDLERS'}->{'BAN'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "BAN: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_SET_INFO) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_SET_INFO'})) { &{$self->{'HANDLERS'}->{'FILE_SET_INFO'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "SET INFO: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_FILE_DELETE) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_DELETE'})) { &{$self->{'HANDLERS'}->{'FILE_DELETE'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "DELETE FILE: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_FILE_MKDIR) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_MKDIR'})) { &{$self->{'HANDLERS'}->{'FILE_MKDIR'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "CREATE FOLDER: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_FILE_MOVE) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_MOVE'})) { &{$self->{'HANDLERS'}->{'FILE_MOVE'}}($self, $task); } elsif($self->{'DEFAULT_HANDLERS'}) { print "MOVE FILE: Task complete.\n"; } } } elsif($task_type == HTLC_TASK_FILE_GET) { my($size) = $packet->{'HTXF_SIZE'}; my($ref) = $packet->{'HTXF_REF'}; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_GET'})) { &{$self->{'HANDLERS'}->{'FILE_GET'}}($self, $task, $ref, $size); } else { print "GET FILE: Starting download (ref = $ref, size = $size)\n" if($self->{'DEFAULT_HANDLERS'}); $self->recv_file($task, $ref, $size); } } } elsif($task_type == HTLC_TASK_FILE_PUT) { my($ref) = $packet->{'HTXF_REF'}; my($resume) = $packet->{'HTXF_RFLT'}; my($size) = ${$task->misc()}[0] + ${$task->misc()}[1]; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'FILE_PUT'})) { &{$self->{'HANDLERS'}->{'FILE_PUT'}}($self, $task, $ref, $size, $resume); } else { print "GET PUT: Starting upload (ref = $ref)\n" if($self->{'DEFAULT_HANDLERS'}); $self->send_file($task, $ref, $size, $resume); } } } elsif($task_type == HTLC_TASK_PCHAT_CREATE) { my($ref) = $packet->{'PCHAT_REF'}; my($user) = $self->{'USER_LIST'}->{$packet->{'SOCKET'}}; my($pchat) = $self->{'PCHATS'}->{$ref} = new Net::Hotline::PrivateChat; $pchat->reference($ref); $pchat->userlist({ $packet->{'SOCKET'} => $user }); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_CREATE'})) { &{$self->{'HANDLERS'}->{'PCHAT_CREATE'}}($self, $task, $pchat); } elsif($self->{'DEFAULT_HANDLERS'}) { print "CREATE PCHAT($ref): Task complete.\n"; } } } elsif($task_type == HTLC_TASK_PCHAT_ACCEPT) { my($ref) = $task->misc(); my($userlist); # Create userlist of references to the main userlist rather # than new user objects (as returned in the packet) foreach my $socket (keys(%{$packet->{'USER_LIST'}})) { $userlist->{$socket} = $self->{'USER_LIST'}->{$socket}; } my($pchat) = $self->{'PCHATS'}->{$ref} = new Net::Hotline::PrivateChat($ref, $userlist); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_ACCEPT'})) { &{$self->{'HANDLERS'}->{'PCHAT_ACCEPT'}}($self, $task, $pchat); } elsif($self->{'DEFAULT_HANDLERS'}) { print "ACCEPT PCHAT INVITE($ref): Task complete.\n"; } } } } # Reclaim memory delete $self->{'TASKS'}->{$packet->{'TASK_NUM'}}; } elsif($type == HTLS_HDR_AGREEMENT) { $self->{'AGREEMENT'} = $packet->{'DATA'}; if(defined($packet->{'DATA'})) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'AGREEMENT'})) { &{$self->{'HANDLERS'}->{'AGREEMENT'}}($self, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "AGREEMENT:\n", $packet->{'DATA'}, "\n"; } } } } elsif($type == HTLS_HDR_MSG) { my($user) = $self->{'USER_LIST'}->{$packet->{'SOCKET'}}; # User-to-user message if(defined($user) && defined($packet->{'DATA'})) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'MSG'})) { &{$self->{'HANDLERS'}->{'MSG'}}($self, $user, \$packet->{'DATA'}, \$packet->{'REPLY_TO'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "MSG: ", $user->nick(), "(", $packet->{'SOCKET'}, ") ", $packet->{'DATA'}; if($packet->{'IS_REPLY'}) { print " (In reply to: $packet->{'REPLY_TO'}])"; } print "\n"; } } } elsif(defined($packet->{'DATA'})) # Server message { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'SERVER_MSG'})) { &{$self->{'HANDLERS'}->{'SERVER_MSG'}}($self, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "SERVER MSG: ", $packet->{'DATA'}, "\n"; } } } } elsif($type == HTLS_HDR_USER_CHANGE) { if(defined($packet->{'NICK'}) && defined($packet->{'SOCKET'}) && defined($packet->{'ICON'}) && defined($packet->{'COLOR'})) { if(defined($self->{'USER_LIST'}->{$packet->{'SOCKET'}})) { my($user) = $self->{'USER_LIST'}->{$packet->{'SOCKET'}}; if($user->nick() ne $packet->{'NICK'}) { my($old_nick) = $user->nick(); $user->nick($packet->{'NICK'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'NICK'})) { &{$self->{'HANDLERS'}->{'NICK'}}($self, $user, $old_nick, $user->nick()); } elsif($self->{'DEFAULT_HANDLERS'}) { print "USER CHANGE: $old_nick is now known as ", $user->nick(), "\n"; } } } elsif($user->icon() ne $packet->{'ICON'}) { my($old_icon) = $user->icon(); $user->icon($packet->{'ICON'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'ICON'})) { &{$self->{'HANDLERS'}->{'ICON'}}($self, $user, $old_icon, $user->icon()); } elsif($self->{'DEFAULT_HANDLERS'}) { print "USER CHANGE: ", $user->nick(), " icon changed from $old_icon to ", $user->icon(), "\n"; } } } elsif($user->color() ne $packet->{'COLOR'}) { my($old_color) = $user->color(); $user->color($packet->{'COLOR'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'COLOR'})) { &{$self->{'HANDLERS'}->{'COLOR'}}($self, $user, $old_color, $user->color()); } elsif($self->{'DEFAULT_HANDLERS'}) { print "USER CHANGE: ", $user->nick(), " color changed from $old_color to ", $user->color(), "\n"; } } } } else { $self->{'USER_LIST'}->{$packet->{'SOCKET'}} = new Net::Hotline::User($packet->{'SOCKET'}, $packet->{'NICK'}, undef, $packet->{'ICON'}, $packet->{'COLOR'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'JOIN'})) { &{$self->{'HANDLERS'}->{'JOIN'}}($self, $self->{'USER_LIST'}->{$packet->{'SOCKET'}}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "JOINED:\n", " Nick: $packet->{'NICK'}\n", " Icon: $packet->{'ICON'}\n", "Socket: $packet->{'SOCKET'}\n", " Color: $packet->{'COLOR'}\n"; } } } } } elsif($type == HTLS_HDR_CHAT) { if(defined($packet->{'DATA'})) { $packet->{'DATA'} =~ s/^\n//s; my($ref) = $packet->{'PCHAT_REF'}; if($ref) # Priate chat { # Private chat "action" if($packet->{'DATA'} =~ /^ \*\*\* /) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_ACTION'})) { &{$self->{'HANDLERS'}->{'PCHAT_ACTION'}}($self, $ref, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "PCHAT($ref) ACTION: ", $packet->{'DATA'}, "\n"; } } } else # Regular private chat { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_CHAT'})) { &{$self->{'HANDLERS'}->{'PCHAT_CHAT'}}($self, $ref, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "PCHAT($ref): ", $packet->{'DATA'}, "\n"; } } } } else # Regular chat { # Chat "action" if($packet->{'DATA'} =~ /^ \*\*\* /) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'CHAT_ACTION'})) { &{$self->{'HANDLERS'}->{'CHAT_ACTION'}}($self, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "CHAT ACTION: ", $packet->{'DATA'}, "\n"; } } } else # Regular chat { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'CHAT'})) { &{$self->{'HANDLERS'}->{'CHAT'}}($self, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "CHAT: ", $packet->{'DATA'}, "\n"; } } } } } } elsif($type == HTLS_HDR_NEWS_POST) { my($post) = $packet->{'DATA'}; if(defined($post)) { $post =~ s/@{[HTLC_NEWLINE]}/\n/osg; $post =~ s/_{58}//sg; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'NEWS_POSTED'})) { &{$self->{'HANDLERS'}->{'NEWS_POSTED'}}($self, \$post); } elsif($self->{'DEFAULT_HANDLERS'}) { print "NEWS: New post made.\n"; } } } } elsif($type == HTLS_HDR_POLITE_QUIT || $type eq 'DISCONNECTED') { if(defined($packet->{'DATA'})) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'QUIT'})) { &{$self->{'HANDLERS'}->{'QUIT'}}($self, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "CONNECTION CLOSED: ", $packet->{'DATA'}, "\n"; } } } elsif($self->{'DEFAULT_HANDLERS'}) { if($use_handlers) { print "CONNECTION CLOSED\n"; } } $self->disconnect(); return(0); } elsif($type == HTLS_HDR_PCHAT_INVITE) { if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_INVITE'})) { &{$self->{'HANDLERS'}->{'PCHAT_INVITE'}}($self, $packet->{'PCHAT_REF'}, $packet->{'SOCKET'}, $packet->{'NICK'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "PCHAT INVITE($packet->{'PCHAT_REF'}) from $packet->{'NICK'}($packet->{'SOCKET'})", "($packet->{'SOCKET)'})\n"; } } } elsif($type == HTLS_HDR_PCHAT_USER_JOIN) { my($ref) = $packet->{'PCHAT_REF'}; my($socket) = $packet->{'SOCKET'}; my($pchat) = $self->{'PCHATS'}->{$ref}; $pchat->userlist()->{$socket} = $self->{'USER_LIST'}->{$socket}; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_JOIN'})) { &{$self->{'HANDLERS'}->{'PCHAT_JOIN'}}($self, $pchat, $socket); } elsif($self->{'DEFAULT_HANDLERS'}) { print "PCHAT($ref) JOIN($socket)\n"; } } } elsif($type == HTLS_HDR_PCHAT_USER_LEAVE) { my($ref) = $packet->{'PCHAT_REF'}; my($socket) = $packet->{'SOCKET'}; my($pchat) = $self->{'PCHATS'}->{$ref}; delete $pchat->userlist()->{$socket}; if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_LEAVE'})) { &{$self->{'HANDLERS'}->{'PCHAT_LEAVE'}}($self, $pchat, $socket); } elsif($self->{'DEFAULT_HANDLERS'}) { print "PCHAT($ref) LEAVE($socket)\n"; } } } elsif($type == HTLS_HDR_PCHAT_SUBJECT) { my($pchat) = $self->{'PCHATS'}->{$packet->{'PCHAT_REF'}}; $pchat->subject($packet->{'DATA'}); if($use_handlers) { if(defined($self->{'HANDLERS'}->{'PCHAT_SUBJECT'})) { &{$self->{'HANDLERS'}->{'PCHAT_SUBJECT'}}($self, $pchat, \$packet->{'DATA'}); } elsif($self->{'DEFAULT_HANDLERS'}) { print "PCHAT(", $pchat->reference(), ") Subject set to: $packet->{'DATA'}\n"; } } } return(1); } sub _handler { my($self, $code_ref, $type) = @_; if(defined($code_ref)) { if(ref($code_ref) eq 'CODE') { $self->{'HANDLERS'}->{$type} = $code_ref; } } return $self->{'HANDLERS'}->{$type}; } sub _next_seqnum { my($self) = shift; return $self->{'SEQNUM'}++; } sub agreement_handler { return _handler($_[0], $_[1], 'AGREEMENT') } sub ban_handler { return _handler($_[0], $_[1], 'BAN') } sub chat_handler { return _handler($_[0], $_[1], 'CHAT') } sub chat_action_handler { return _handler($_[0], $_[1], 'CHAT_ACTION') } sub color_handler { return _handler($_[0], $_[1], 'COLOR') } sub event_loop_handler { return _handler($_[0], $_[1], 'EVENT') } sub delete_file_handler { return _handler($_[0], $_[1], 'FILE_DELETE') } sub get_file_handler { return _handler($_[0], $_[1], 'FILE_GET') } sub put_file_handler { return _handler($_[0], $_[1], 'FILE_PUT') } sub file_info_handler { return _handler($_[0], $_[1], 'FILE_GET_INFO') } sub file_list_handler { return _handler($_[0], $_[1], 'FILE_LIST') } sub new_folder_handler { return _handler($_[0], $_[1], 'FILE_MKDIR') } sub move_file_handler { return _handler($_[0], $_[1], 'FILE_MOVE') } sub set_file_info_handler { return _handler($_[0], $_[1], 'FILE_SET_INFO') } sub icon_handler { return _handler($_[0], $_[1], 'ICON') } sub join_handler { return _handler($_[0], $_[1], 'JOIN') } sub kick_handler { return _handler($_[0], $_[1], 'KICK') } sub leave_handler { return _handler($_[0], $_[1], 'LEAVE') } sub login_handler { return _handler($_[0], $_[1], 'LOGIN') } sub msg_handler { return _handler($_[0], $_[1], 'MSG') } sub news_handler { return _handler($_[0], $_[1], 'NEWS') } sub post_news_handler { return _handler($_[0], $_[1], 'NEWS_POST') } sub news_posted_handler { return _handler($_[0], $_[1], 'NEWS_POSTED') } sub nick_handler { return _handler($_[0], $_[1], 'NICK') } sub pchat_accept_handler { return _handler($_[0], $_[1], 'PCHAT_ACCEPT') } sub pchat_action_handler { return _handler($_[0], $_[1], 'PCHAT_ACTION') } sub pchat_chat_handler { return _handler($_[0], $_[1], 'PCHAT_CHAT') } sub pchat_create_handler { return _handler($_[0], $_[1], 'PCHAT_CREATE') } sub pchat_invite_handler { return _handler($_[0], $_[1], 'PCHAT_INVITE') } sub pchat_join_handler { return _handler($_[0], $_[1], 'PCHAT_JOIN') } sub pchat_leave_handler { return _handler($_[0], $_[1], 'PCHAT_LEAVE') } sub pchat_subject_handler { return _handler($_[0], $_[1], 'PCHAT_SUBJECT') } sub quit_handler { return _handler($_[0], $_[1], 'QUIT') } sub send_msg_handler { return _handler($_[0], $_[1], 'SEND_MSG') } sub server_msg_handler { return _handler($_[0], $_[1], 'SERVER_MSG') } sub task_error_handler { return _handler($_[0], $_[1], 'TASK_ERROR') } sub user_info_handler { return _handler($_[0], $_[1], 'USER_GETINFO') } sub user_list_handler { return _handler($_[0], $_[1], 'USER_LIST') } # # Package subroutines # sub version { $Net::Hotline::Client::VERSION } sub debug { if(@_ == 1 && !ref($_[0])) { $Net::Hotline::Client::DEBUG = ($_[0]) ? 1 : 0; } elsif(@_ == 2 && ref($_[0]) eq 'Net::Hotline::Client') { $Net::Hotline::Client::DEBUG = ($_[1]) ? 1 : 0; } return $Net::Hotline::Client::DEBUG; } sub _hlc_write { my($self, $fh, $data_ref, $len) = @_; return("0-E0") if($len == 0 || !defined($len)); unless(_write($fh, $data_ref, $len) == $len) { $self->{'LAST_ERROR'} = "Write error: $!"; return; } return($len); } sub _hlc_read { my($self, $fh, $data_ref, $len) = @_; return("0-E0") if($len == 0 || !defined($len)); unless(_read($fh, $data_ref, $len) == $len) { $self->{'LAST_ERROR'} = "Read error: $!"; return; } return($len); } sub _hlc_buffered_read { my($self, $fh, $data_ref, $len) = @_; return("0-E0") if($len == 0 || !defined($len)); unless(read($fh, $$data_ref, $len) == $len) { $self->{'LAST_ERROR'} = "Read error: $!"; return; } return($len); } # Macbinary CRC perl code from Convert::BinHex by Eryq (eryq@enteract.com) # (It needs access to the lexical @CRC_MAGIC, so it can't be auto-loaded) sub macbin_crc { shift if(ref($_[0])); my($len) = length($_[0]); my($crc) = $_[1]; for(my $i = 0; $i < $len; $i++) { ($crc ^= (vec($_[0], $i, 8) << 8)) &= 0xFFFF; $crc = ($crc << 8) ^ $CRC_MAGIC[$crc >> 8]; } return $crc; } # # Satisfy autoloader's ridiculous *8-character* unique name limit :-/ # sub get_filelist { al01_get_filelist(@_) } sub get_fileinfo { al02_get_fileinfo(@_) } sub get_userinfo { al03_get_userinfo(@_) } sub user_by_nick { al04_user_by_nick(@_) } sub req_userlist { al05_req_userlist(@_) } sub req_filelist { al06_req_filelist(@_) } sub pchat_action { al07_pchat_action(@_) } sub get_file { al08_get_file(@_) } sub put_file { al09_put_file(@_) } # Internal functions that were also munged up: # _al01_put_file_resume_now # _al02_get_file_resume_now # _al03_delete_file_now # _al04_new_folder_now # _al05_put_file_now # _al06_put_file_resume # _al07_get_file_now # _al08_get_file_resume # _al09_file_action_stub # _al10_post_news_now # _al11_pchat_invite_now # _al12_pchat_accept_now # _al13_comment_now __END__ # # Auto-loaded methods and subroutines # sub logged_in { $_[0]->{'LOGGED_IN'} } sub connected { (ref($_[0]->{'SERVER'}) && $_[0]->{'SERVER'}->opened()) ? 1 : 0; } sub _blocking_task { my($self, $task_num) = @_; my($packet, $ret); $packet = new Net::Hotline::Protocol::Packet; while($ret = $packet->read_parse($self->{'SERVER'}, $self->{'BLOCKING'})) { _process_packet($self, $packet, $ret, 'blocking task'); if($packet->{'TYPE'} == HTLS_HDR_TASK && $packet->{'TASK_NUM'} == $task_num) { return($packet); } } } sub al01_get_filelist { my($self, $path) = @_; my($task, $task_num, $packet); $task_num = $self->req_filelist($path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return(0); } $path = $task->path(); $path = "" unless(length($path)); if(wantarray) { return @{$self->{'FILES'}->{$path}}; } else { return $self->{'FILES'}->{$path}; } } sub al06_req_filelist { my($self, $path) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data, $task_num, @path_parts, $path_part, $data_length, $length, $save_path); $path =~ s/^$self->{'PATH_SEPARATOR'}//; $path =~ s/$self->{'PATH_SEPARATOR'}$//; if(length($path)) { $save_path = $path; @path_parts = split($self->{'PATH_SEPARATOR'}, $path); $path =~ s/$self->{'PATH_SEPARATOR'}//g; if(length($path) > HTLC_MAX_PATHLEN) { croak("Maximum path length exceeded"); } # 2 null bytes, the 1 byte for length, and the length of the path part $data_length = (3 * scalar(@path_parts)) + length($path); $length = SIZEOF_HL_LONG_HDR + $data_length; } else { $length = 2; # Two null bytes } my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_FILE_LIST); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len($length); $proto_header->len2($proto_header->len); $data = $proto_header->header(); if(length($path)) { $data .= pack("n4", 0x0001, # Number of atoms HTLC_DATA_DIRECTORY, # Atom type $data_length + 2, # Atom length scalar(@path_parts)); # Number of path parts foreach $path_part (@path_parts) # Path parts data { if(length($path_part) > HTLC_MAX_PATHLEN) { croak("Maximum path part length exceeded"); } $data .= pack("nCa*", 0x0000, # 2 null bytes length $path_part,# Length $path_part); # Path part } } else { $data .= pack("n", 0x0000); } _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: FILE_LIST - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_FILE_LIST, time(), undef, $save_path); return($task_num); } else { return } } sub al03_get_userinfo { my($self, $socket) = @_; my($task, $task_num, $packet); $task_num = $self->req_userinfo($socket); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return $self->{'USER_LIST'}->{$task->socket()}->info(); } sub req_userinfo { my($self, $socket) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data, $task_num); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_USER_GETINFO); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_LONG_HDR); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n4", 0x0001, # Number of atoms HTLC_DATA_SOCKET, # Atom type 0x0002, # Atom length $socket); # Atom data _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: USER_GETINFO - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_USER_INFO, time(), $socket); return($task_num); } else { return } } sub al02_get_fileinfo { my($self, $path) = @_; my($task, $task_num, $packet); $task_num = $self->req_fileinfo($path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return $self->{'FILE_INFO'}; } sub req_fileinfo { return _file_action_simple($_[0], $_[1], HTLC_HDR_FILE_GETINFO, HTLC_TASK_FILE_INFO, 'GET FILE INFO'); } sub delete_file { my($self, $path) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al03_delete_file_now($path); } else { return $self->_delete_file($path); } } sub _al03_delete_file_now { my($self, $path) = @_; my($task, $task_num, $packet); $task_num = $self->_delete_file($path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _delete_file { return _file_action_simple($_[0], $_[1], HTLC_HDR_FILE_DELETE, HTLC_TASK_FILE_DELETE, 'DELETE FILE'); } sub new_folder { my($self, $path) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al04_new_folder_now($path); } else { return $self->_new_folder($path); } } sub _al04_new_folder_now { my($self, $path) = @_; my($task, $task_num, $packet); $task_num = $self->_new_folder($path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _new_folder { return _file_action_simple($_[0], $_[1], HTLC_HDR_FILE_MKDIR, HTLC_TASK_FILE_MKDIR, 'NEW FOLDER'); } sub al09_put_file { my($self, $src_path, $dest_path, $comments) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al05_put_file_now($src_path, $dest_path, $comments); } else { return $self->_put_file($src_path, $dest_path, $comments); } } sub _al05_put_file_now { my($self, $src_path, $dest_path, $comments) = @_; my($task, $task_num, $packet, $size); $task_num = $self->_put_file($src_path, $dest_path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } $size = ${$task->misc()}[0] + ${$task->misc()}[1]; if(wantarray) { return($task, $packet->{'HTXF_REF'}, $size); } else { return [ $task, $packet->{'HTXF_REF'}, $size ]; } } sub _put_file { my($self, $src_path, $dest_path, $comments) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; croak("Not connected.") unless($server->opened()); unless(-e $src_path) { $self->{'LAST_ERROR'} = "File does not exist: $src_path"; return; } my($local_sep, $remote_sep, $src_file, $data, $task_num, $length, $num_atoms, $data_len, $rsrc_len, $finder_flags, $type, $creator); $local_sep = PATH_SEPARATOR; $remote_sep = $self->{'PATH_SEPARATOR'}; ($src_file = $src_path) =~ s/.*?$local_sep([^$local_sep]+)$/$1/o; $dest_path = "$dest_path$remote_sep$src_file"; ($data, $task_num) = _al09_file_action_stub($self, $dest_path, HTLC_HDR_FILE_PUT); # Set new length: old length plus 8 bytes for the size atom $length = (unpack("N", substr($data, 16, 4)) + 8); substr($data, 16, 4) = pack("N", $length); substr($data, 12, 4) = pack("N", $length); # Set new num atoms: old num atoms + 1 $num_atoms = (unpack("n", substr($data, 20, 2)) + 1); substr($data, 20, 2) = pack("n", $num_atoms); # Fork lengths $data_len = (stat($src_path))[7]; $rsrc_len = 0; # Mac OS specific information: resource fork length and finder comments if($self->{'MACOS'}) { my($fsspec, $finder_comments, $res_fd, $rsrc_fh, $cat, $finfo); $fsspec = MacPerl::MakeFSSpec($src_path); # Get finder comments unless(defined($comments)) { $finder_comments = Mac::MoreFiles::FSpDTGetComment($fsspec); $comments = $finder_comments if(length($finder_comments)); } $cat = Mac::Files::FSpGetCatInfo($fsspec); $finfo = $cat->ioFlFndrInfo(); # Get finder flags, type, and creator $finder_flags = $finfo->fdFlags(); $type = $finfo->fdType(); $creator = $finfo->fdCreator(); # Protect from compile-time errors on non-Mac OS systems that don't # define O_RSRC in Fcntl eval '$res_fd = POSIX::open($src_path, O_RDONLY | O_RSRC)'; $rsrc_fh = new IO::File; unless($rsrc_fh->fdopen($res_fd, "r")) { $self->{'LAST_ERROR'} = "Couldn't open Mac resource fork: $@"; return; } $rsrc_fh->seek(0, SEEK_END); # Fast forward to end $rsrc_len = $rsrc_fh->tell(); # Get size $rsrc_fh->seek(0, SEEK_SET); # Rewind } else { ($type, $creator) = ("BINA", "????"); } # Total length of the upload to come: 111 bytes for type/creator/etc. # + 1 byte for the file name length + the file name + 2 bytes for the # comments length + the comments + 2 fork headers + the size of the # file to be uploaded (size of data fork plus size of resource fork). $length = (SIZEOF_HL_FILE_UPLOAD_HDR + 1 + length($src_file) + 2 + length($comments) + (2 * SIZEOF_HL_FILE_FORK_HDR) + $data_len + $rsrc_len); # 00 00 00 CB 00 00 00 06 00 00 00 00 00 00 00 21 ...............! # 00 00 00 21 00 03 00 C9 00 05 74 65 78 74 32 00 ...!......text2. # CA 00 0C 00 01 00 00 07 55 70 6C 6F 61 64 73 00 ........Uploads. # 6C 00 02 03 94 l.... # Add size argument $data .= pack("nnN", HTLC_DATA_HTXF_SIZE, # Atom type 0x0004, # Atom length $length); # Atom data _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: PUT FILE - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_FILE_PUT, time(), undef, [ $src_path, $dest_path ], [ $data_len, $rsrc_len, $comments, $finder_flags, $type, $creator, $length ]); return($task_num); } else { return } } sub put_file_resume { my($self, $src_path, $dest_path, $comments) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al01_put_file_resume_now($src_path, $dest_path, $comments); } else { return $self->_al06_put_file_resume($src_path, $dest_path, $comments); } } sub _al01_put_file_resume_now { my($self, $src_path, $dest_path, $comments) = @_; my($task, $task_num, $packet); $task_num = $self->_al06_put_file_resume($src_path, $dest_path, $comments); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } if(wantarray) { return($task, $packet->{'HTXF_REF'}, ${$task->misc()}[6], $packet->{'HTXF_RFLT'}); } else { return [ $task, $packet->{'HTXF_REF'}, ${$task->misc()}[6], $packet->{'HTXF_RFLT'} ]; } } sub _al06_put_file_resume { my($self, $src_path, $dest_path, $comments) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; croak("Not connected.") unless($server->opened()); unless(-e $src_path) { $self->{'LAST_ERROR'} = "File does not exist: $src_path"; return; } my($local_sep, $remote_sep, $src_file, $data, $task_num, $length, $num_atoms, $data_len, $rsrc_len, $finder_flags, $type, $creator); $local_sep = PATH_SEPARATOR; $remote_sep = $self->{'PATH_SEPARATOR'}; ($src_file = $src_path) =~ s/.*?$local_sep([^$local_sep]+)$/$1/o; $dest_path = "$dest_path$remote_sep$src_file"; ($data, $task_num) = _al09_file_action_stub($self, $dest_path, HTLC_HDR_FILE_PUT); # Add upload resume magic $data .= HTXF_RESUME_MAGIC; # Set new length: old length plus the length of HTXF_RESUME_MAGIC $length = (unpack("N", substr($data, 16, 4)) + length(HTXF_RESUME_MAGIC)); substr($data, 16, 4) = pack("N", $length); substr($data, 12, 4) = pack("N", $length); # Set new num atoms: old num atoms + 1 $num_atoms = (unpack("n", substr($data, 20, 2)) + 1); substr($data, 20, 2) = pack("n", $num_atoms); # Fork lengths $data_len = (stat($src_path))[7]; $rsrc_len = 0; # Mac OS specific information: resource fork length and finder comments if($self->{'MACOS'}) { my($fsspec, $finder_comments, $res_fd, $rsrc_fh, $cat, $finfo); $fsspec = MacPerl::MakeFSSpec($src_path); # Get finder comments unless(defined($comments)) { $finder_comments = Mac::MoreFiles::FSpDTGetComment($fsspec); $comments = $finder_comments if(length($finder_comments)); } $cat = Mac::Files::FSpGetCatInfo($fsspec); $finfo = $cat->ioFlFndrInfo(); # Get finder flags, type, and creator $finder_flags = $finfo->fdFlags(); $type = $finfo->fdType(); $creator = $finfo->fdCreator(); # Protect from compile-time errors on non-Mac OS systems that don't # define O_RSRC in Fcntl eval '$res_fd = POSIX::open($src_path, O_RDONLY | O_RSRC)'; $rsrc_fh = new IO::File; unless($rsrc_fh->fdopen($res_fd, "r")) { $self->{'LAST_ERROR'} = "Couldn't open Mac resource fork: $@"; return; } $rsrc_fh->seek(0, SEEK_END); # Fast forward to end $rsrc_len = $rsrc_fh->tell(); # Get size $rsrc_fh->seek(0, SEEK_SET); # Rewind } else { ($type, $creator) = ("BINA", "????"); } # Total length of the upload to come: 111 bytes for type/creator/etc. # + 1 byte for the file name length + the file name + 2 bytes for the # comments length + the comments + 2 fork headers + the size of the # file to be uploaded (size of data fork plus size of resource fork). $length = (SIZEOF_HL_FILE_UPLOAD_HDR + 1 + length($src_file) + 2 + length($comments) + (2 * SIZEOF_HL_FILE_FORK_HDR) + $data_len + $rsrc_len); _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: PUT FILE - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_FILE_PUT, time(), undef, [ $src_path, $dest_path ], [ $data_len, $rsrc_len, $comments, $finder_flags, $type, $creator, $length ]); return($task_num); } else { return } } sub al08_get_file { my($self, $path) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al07_get_file_now($path); } else { return $self->_get_file($path); } } sub _al07_get_file_now { my($self, $path) = @_; my($task, $task_num, $packet); $task_num = $self->_get_file($path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } if(wantarray) { return(($task, $packet->{'HTXF_REF'}, $packet->{'HTXF_SIZE'})); } else { return [ $task, $packet->{'HTXF_REF'}, $packet->{'HTXF_SIZE'} ]; } } sub _get_file { my($self, $path) = @_; my($local_sep, $remote_sep, $dest_dir, $task_num, $data_file, $rsrc_file); $local_sep = PATH_SEPARATOR; $remote_sep = $self->{'PATH_SEPARATOR'}; $dest_dir = $self->{'DOWNLOADS_DIR'}; $dest_dir .= $local_sep if($dest_dir =~ /\S/ && $dest_dir !~ /$local_sep$/o); ($data_file = $path) =~ s/.*?$remote_sep([^$remote_sep]+)$/$1/; if($self->{'MACOS'}) { $rsrc_file = undef; } else { $rsrc_file = "$data_file$self->{'RSRC_FORK_EXT'}"; $data_file = "$data_file$self->{'DATA_FORK_EXT'}"; } $task_num = _file_action_simple($self, $path, HTLC_HDR_FILE_GET, HTLC_TASK_FILE_GET, 'GET FILE'); return unless(defined($task_num)); $self->{'TASKS'}->{$task_num}->path([ $path, $data_file, $rsrc_file ]); return($task_num); } sub get_file_resume { my($self, $path) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al02_get_file_resume_now($path); } else { return $self->_al08_get_file_resume($path); } } sub _al02_get_file_resume_now { my($self, $path) = @_; my($task, $task_num, $packet); $task_num = $self->_al08_get_file_resume($path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } if(wantarray) { return(($task, $packet->{'HTXF_REF'}, $packet->{'HTXF_SIZE'})); } else { return [ $task, $packet->{'HTXF_REF'}, $packet->{'HTXF_SIZE'} ]; } } sub _al08_get_file_resume { my($self, $path) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; croak("Not connected.") unless($server->opened()); my($local_sep, $remote_sep, $dest_dir, $data, $more_data, $task_num, $length, $data_file, $data_pos, $rsrc_file, $rsrc_pos); $local_sep = PATH_SEPARATOR; $remote_sep = $self->{'PATH_SEPARATOR'}; $dest_dir = $self->{'DOWNLOADS_DIR'}; $dest_dir .= $local_sep if($dest_dir =~ /\S/ && $dest_dir !~ /$local_sep$/o); ($data, $task_num) = _al09_file_action_stub($self, $path, HTLC_HDR_FILE_GET); $data_file = $path; if($data_file =~ /$remote_sep([^$remote_sep]+)$/) { $data_file = "$dest_dir$1"; } else { $data_file = "$dest_dir$data_file"; } if($self->{'MACOS'}) { $rsrc_file = undef; } else { $rsrc_file = "$data_file$self->{'RSRC_FORK_EXT'}"; $data_file = "$data_file$self->{'DATA_FORK_EXT'}"; } unless(-e $data_file || -e $rsrc_file) { $self->{'LAST_ERROR'} = "Can't resume download: partial download does not exist."; return; } # Get data fork position $data_pos = (stat($data_file))[7]; # Get resource fork position if($self->{'MACOS'}) { my($res_fd, $rsrc_fh); # Protect from compile-time errors on non-Mac OS systems that don't # define O_RSRC in Fcntl eval '$res_fd = POSIX::open($data_file, O_RDONLY | O_RSRC)'; $rsrc_fh = new IO::File; unless($rsrc_fh->fdopen($res_fd, "r")) { $self->{'LAST_ERROR'} = "Couldn't open Mac resource fork: $@"; return; } $rsrc_fh->seek(0, SEEK_END); # Fast forward to end $rsrc_pos = $rsrc_fh->tell(); # Get size $rsrc_fh->seek(0, SEEK_SET); # Rewind } else { $rsrc_pos = (stat($rsrc_file))[7]; } $length = unpack("N", substr($data, 16, 4)); $length += 78; # Set new length substr($data, 12, 4) = pack("N", $length); substr($data, 16, 4) = pack("N", $length); # Set new num atoms my($num_atoms) = unpack("n", substr($data, 20, 2)); substr($data, 20, 2) = pack("n", $num_atoms + 1); # 00 CB 00 4A 52 46 4C 54 00 01 00 00 00 00 00 00 ...JRFLT........ # 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ # 00 00 00 00 00 00 00 00 00 00 00 00 00 02 44 41 ..............DA # 54 41 00 00 1B EA 00 00 00 00 00 00 00 00 4D 41 TA............MA # 43 52 00 00 00 00 00 00 00 00 00 00 00 00 CR............ $more_data = pack("x78"); substr($more_data, 0, 2) = pack("n", HTLC_DATA_RFLT); substr($more_data, 2, 2) = pack("n", 0x004A); substr($more_data, 4, 4) = HTXF_RFLT_MAGIC; substr($more_data, 8, 2) = pack("n", 0x0001); substr($more_data, 45, 1) = pack("C", 0x02); substr($more_data, 46, 4) = 'DATA'; substr($more_data, 50, 4) = pack("N", $data_pos); substr($more_data, 62, 4) = 'MACR'; substr($more_data, 66, 4) = pack("N", $rsrc_pos); $data .= $more_data; _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: GET FILE - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_FILE_GET, time(), undef, [ $path, $data_file, $rsrc_file ]); return($task_num); } else { return } } sub _al09_file_action_stub { my($self, $path, $type) = @_; my($data, @path_parts, $length, $file, $dir_len); $path =~ s/^$self->{'PATH_SEPARATOR'}//; $path =~ s/$self->{'PATH_SEPARATOR'}$//; @path_parts = split($self->{'PATH_SEPARATOR'}, $path); $path =~ s/$self->{'PATH_SEPARATOR'}//g; if(length($path) > HTLC_MAX_PATHLEN) { croak("Maximum path length exceeded"); } $file = pop(@path_parts); # File part: 2 bytes num atoms, 2 bytes for atom len, # 2 bytes for file name length $length = (2 + 2 + 2 + length($file)); if(@path_parts) { $dir_len = length(join('', @path_parts)); # Path part: 2 bytes for atom type, 2 bytes for atom len # 2 bytes for num path components, and 2 null bytes and # 1 byte path part length for each path part $length += (2 + 2 + 2 + (3 * @path_parts)); $length += $dir_len; } my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type($type); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len($length); $proto_header->len2($proto_header->len); $data = $proto_header->header(); $data .= pack("n3a*", @path_parts ? 2 : 1, # Number of atoms HTLC_DATA_FILE, # Atom type length($file), # Atom length $file); # Atom data if(@path_parts) { $data .= pack("n3", HTLC_DATA_DIRECTORY, # Atom type $dir_len + 2 + (3 * scalar(@path_parts)), # Atom length scalar(@path_parts)); # Num path parts my($path_part); foreach $path_part (@path_parts) # Path parts data { if(length($path_part) > HTLC_MAX_PATHLEN) { croak("Maximum path part length exceeded"); } $data .= pack("nCa*", 0x0000, # 2 null bytes length($path_part),# Length $path_part); # Path part } } return($data, $proto_header->seq()); } sub _file_action_simple { my($self, $path, $type, $task_type, $task_name) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && length($path)); my($data, $task_num) = _al09_file_action_stub($self, $path, $type); _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: $task_name - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, $task_type, time(), undef, $path); return($task_num); } else { return } } sub move { my($self, $src_path, $dest_path) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_move_now($src_path, $dest_path); } else { return $self->_move($src_path, $dest_path); } } sub _move_now { my($self, $src_path, $dest_path) = @_; my($task, $task_num, $packet); $task_num = $self->_move($src_path, $dest_path); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _move { my($self, $src_path, $dest_path) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && length($src_path) && length($dest_path)); my($data, $task_num, $length, $num_atoms); my(@src_path_parts, $save_src_path, $src_file, $src_dir_len); my(@dest_path_parts, $save_dest_path, $dest_dir_len); # Source: $src_path =~ s/^$self->{'PATH_SEPARATOR'}//; $src_path =~ s/$self->{'PATH_SEPARATOR'}$//; $save_src_path = $src_path; @src_path_parts = split($self->{'PATH_SEPARATOR'}, $src_path); $src_path =~ s/$self->{'PATH_SEPARATOR'}//g; if(length($src_path) > HTLC_MAX_PATHLEN) { croak("Maximum path length exceeded"); } $src_file = pop(@src_path_parts); # Source part: 2 bytes num atoms, 2 bytes for atom type, # 2 bytes for file name length $length = (2 + 2 + 2 + length($src_file)); if(@src_path_parts) { $src_dir_len = length(join('', @src_path_parts)); # Path part: 2 bytes for atom type, 2 bytes for atom len # 2 bytes for num path components, and 2 null bytes and # 1 byte path part length for each path part $length += (2 + 2 + 2 + (3 * @src_path_parts)); $length += $src_dir_len; } # Destination: $dest_path =~ s/^$self->{'PATH_SEPARATOR'}//; $dest_path =~ s/$self->{'PATH_SEPARATOR'}$//; $save_dest_path = $dest_path; @dest_path_parts = split($self->{'PATH_SEPARATOR'}, $dest_path); $dest_path =~ s/$self->{'PATH_SEPARATOR'}//g; if(length($dest_path) > HTLC_MAX_PATHLEN) { croak("Maximum path length exceeded"); } if(@dest_path_parts) { $dest_dir_len = length(join('', @dest_path_parts)); # Path part: 2 bytes for atom type, 2 bytes for atom len # 2 bytes for num path components, and 2 null bytes and # 1 byte path part length for each path part $length += (2 + 2 + 2 + (3 * @dest_path_parts)); $length += $dest_dir_len; } # Build packet if(@src_path_parts && @dest_path_parts) { $num_atoms = 3 } else { $num_atoms = 2 } my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_FILE_MOVE); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len($length); $proto_header->len2($proto_header->len); $data = $proto_header->header(); $data .= pack("n3a*", $num_atoms, # Number of atoms HTLC_DATA_FILE, # Atom type length($src_file), # Atom length $src_file); # Atom data if(@src_path_parts) { $data .= pack("n3", HTLC_DATA_DIRECTORY, # Atom type $src_dir_len + 2 + (3 * scalar(@src_path_parts)), # Atom length scalar(@src_path_parts)); # Num path parts my($path_part); foreach $path_part (@src_path_parts) # Path parts data { if(length($path_part) > HTLC_MAX_PATHLEN) { croak("Maximum path part length exceeded"); } $data .= pack("nCa*", 0x0000, # 2 null bytes length $path_part,# Length $path_part); # Path part } } if(@dest_path_parts) { $data .= pack("n3", HTLC_DATA_DESTDIR, # Atom type $dest_dir_len + 2 + (3 * scalar(@dest_path_parts)), # Atom length scalar(@dest_path_parts)); # Num path parts my($path_part); foreach $path_part (@dest_path_parts) # Path parts data { if(length($path_part) > HTLC_MAX_PATHLEN) { croak("Maximum path part length exceeded"); } $data .= pack("nCa*", 0x0000, # 2 null bytes length $path_part,# Length $path_part); # Path part } } _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: MOVE FILE - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_FILE_MOVE, time(), undef, [ $save_src_path, $save_dest_path ]); return($task_num); } else { return } } sub rename { my($self, $path, $new_name) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_rename_now($path, $new_name); } else { return $self->_rename($path, $new_name); } } sub _rename_now { my($self, $path, $new_name) = @_; my($task, $task_num, $packet); $task_num = $self->rename($path, $new_name); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _rename { my($self, $path, $new_name) = @_; return undef unless(length($path) && length($new_name)); return _change_file_info($self, $path, $new_name, undef); } sub comment { my($self, $path, $comments) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al13_comment_now($path, $comments); } else { return $self->_comment($path, $comments); } } sub _al13_comment_now { my($self, $path, $comments) = @_; my($task, $task_num, $packet); $task_num = $self->comment($path, $comments); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _comment { my($self, $path, $comments) = @_; return undef unless(length($path)); $comments = "" unless(defined($comments)); return _change_file_info($self, $path, undef, $comments); } sub _change_file_info { my($self, $path, $name, $comments) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data, $task_num, @path_parts, $length, $save_path, $file, $dir_len, $num_atoms); $path =~ s/^$self->{'PATH_SEPARATOR'}//; $path =~ s/$self->{'PATH_SEPARATOR'}$//; $save_path = $path; @path_parts = split($self->{'PATH_SEPARATOR'}, $path); $path =~ s/$self->{'PATH_SEPARATOR'}//g; if(length($path) > HTLC_MAX_PATHLEN) { croak("Maximum path length exceeded"); } $file = pop(@path_parts); # File part: 2 bytes for num atoms, 2 bytes for atom type, # 2 bytes for file name length $length = (2 + 2 + 2 + length($file)); if(@path_parts) { $dir_len = length(join('', @path_parts)); # Path part: 2 bytes for atom type, 2 bytes for atom len # 2 bytes for num path components, and 2 null bytes and # 1 byte path part length for each path part $length += (2 + 2 + 2 + (3 * @path_parts)); $length += $dir_len; } if(length($name)) { # Name part: 2 bytes for atom type, 2 bytes for # atom len, and the new name $length += (2 + 2 + length($name)); } if(defined($comments)) { # Comments part: 2 bytes for atom type, 2 bytes for # atom len, length of the new comments, else 1 null # byte if removing comments. $length += 2 + 2; if(length($comments)) { $length += length($comments) } else { $length += 1 } } my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_FILE_SETINFO); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len($length); $proto_header->len2($proto_header->len); $data = $proto_header->header(); $num_atoms = (@path_parts) ? 2 : 1; $num_atoms++ if(length($name)); $num_atoms++ if(defined($comments)); $data .= pack("n3a*", $num_atoms, # Number of atoms HTLC_DATA_FILE, # Atom type length($file), # Atom length $file); # Atom data if(@path_parts) { $data .= pack("n3", HTLC_DATA_DIRECTORY, # Atom type $dir_len + 2 + (3 * scalar(@path_parts)), # Atom length scalar(@path_parts)); # Num path parts my($path_part); foreach $path_part (@path_parts) # Path parts data { if(length($path_part) > HTLC_MAX_PATHLEN) { croak("Maximum path part length exceeded"); } $data .= pack("nCa*", 0x0000, # 2 null bytes length $path_part,# Length $path_part); # Path part } } if(length($name)) { $data .= pack("nna*", HTLC_DATA_FILE_RENAME,# Atom type length($name), # Length $name); # Name } if(defined($comments)) { $data .= pack("n", HTLS_DATA_FILE_COMMENT);# Atom type if(length($comments)) { $data .= pack("na*", length($comments), # Length $comments); # Comments } else # Remove comments { $data .= pack("nx", 0x0001); # Length + null byte } } _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: SET INFO - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_SET_INFO, time(), undef, $save_path); return($task_num); } else { return } } sub post_news { my($self, @post) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al10_post_news_now(@post); } else { return $self->_post_news(@post); } } sub _al10_post_news_now { my($self, @post) = @_; my($task, $task_num, $packet); $task_num = $self->post_news(@post); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _post_news { my($self, @post) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($post) = join('', @post); my($data, $task_num); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_NEWS_POST); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_SHORT_HDR + length($post)); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n3a*", 0x0001, # Number of atoms HTLS_DATA_NEWS_POST, # Atom type length($post), # Atom length $post); # Atom data _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: POST NEWS - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_NEWS_POST, time()); } else { return } return($task_num); } sub get_news { my($self) = shift; my($task, $task_num, $packet); $task_num = $self->req_news(); $task = $self->{'TASKS'}->{$task_num}; return(undef) unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return(undef); } if(wantarray) { return @{$self->{'NEWS'}}; } else { return (@{$self->{'NEWS'}}) ? join('_' x 58, @{$self->{'NEWS'}}) : ""; } } sub req_news { my($self) = shift; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data, $task_num); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_NEWS_GETFILE); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_TASK_FILLER); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n", 0x0000); _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: NEWS - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_NEWS, time()); return($task_num); } else { return } } sub al04_user_by_nick { my($self, $nick_match) = @_; my($socket, @users); eval { m/$nick_match/ }; return undef if($@ || !$self->{'USER_LIST'} || length($nick_match) == 0); foreach $socket (sort { $a <=> $b } keys(%{$self->{'USER_LIST'}})) { if($self->{'USER_LIST'}->{$socket}->nick() =~ /^$nick_match$/) { if(wantarray()) { push(@users, $self->{'USER_LIST'}->{$socket}); } else { return $self->{'USER_LIST'}->{$socket}; } } } if(@users) { return @users } else { return } } sub user_by_socket { my($self, $socket) = @_; return $self->{'USER_LIST'}->{$socket}; } sub icon { my($self, $icon) = @_; return $self->{'ICON'} unless($icon =~ /^-?\d+$/); return _update_user($self, $icon, $self->{'NICK'}); } sub nick { my($self, $nick) = @_; return $self->{'NICK'} unless(defined($nick)); return _update_user($self, $self->{'ICON'}, $nick); } sub _update_user { my($self, $icon, $nick) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_USER_CHANGE); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len((SIZEOF_HL_SHORT_HDR * 2) + length($nick)); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n6a*", 0x0002, # Num atoms HTLC_DATA_ICON, # Atom type 0x0002, # Atom length $icon, # Atom data HTLC_DATA_NICKNAME, # Atom type length($nick), # Atom length $nick); # Atom data $self->{'NICK'} = $nick; $self->{'ICON'} = $icon; _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { return(1); } else { return } } sub get_userlist { my($self) = shift; my($task, $task_num, $packet); $task_num = $self->req_userlist(); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return $self->{'USER_LIST'}; } sub al05_req_userlist { my($self) = shift; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data, $task_num); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_USER_GETLIST); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_TASK_FILLER); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n", 0x0000); _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: GET USER LIST - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_USER_LIST, time()); return($task_num); } else { return } } sub kick { my($self, $user_or_socket) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_kick_now($user_or_socket); } else { return $self->_kick($user_or_socket); } } sub _kick_now { my($self, $user_or_socket) = @_; my($task, $task_num, $packet); $task_num = $self->_kick($user_or_socket); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _kick { my($self, $user_or_socket) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($socket, $task_num); if(ref($user_or_socket)) { $socket = $user_or_socket->socket() } else { $socket = $user_or_socket } my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_USER_KICK); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_LONG_HDR); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n4", 0x0001, # Num atoms HTLC_DATA_SOCKET, # Atom type 0x0002, # Atom length $socket); # Atom data _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: KICK($socket) - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_KICK, time()); } else { return } return ($task_num); } sub ban { my($self, $user_or_socket) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_ban_now($user_or_socket); } else { return $self->_ban($user_or_socket); } } sub _ban_now { my($self, $user_or_socket) = @_; my($task, $task_num, $packet); $task_num = $self->_ban($user_or_socket); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _ban { my($self, $user_or_socket) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($socket, $task_num); if(ref($user_or_socket)) { $socket = $user_or_socket->socket() } else { $socket = $user_or_socket } my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_USER_KICK); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_LONG_HDR + 6); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n7", 0x0002, # Num atoms HTLC_DATA_SOCKET, # Atom type 0x0002, # Atom length $socket, # Atom data HTLC_DATA_BAN, # Atom type 0x0002, # Atom length 0x0001); # Atom data (always 1???) _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: BAN($socket) - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_BAN, time()); } else { return } return ($task_num); } sub msg { my($self, $user_or_socket, @message) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_msg_now($user_or_socket, @message); } else { return $self->_msg($user_or_socket, @message); } } sub _msg_now { my($self, $user_or_socket, @message) = @_; my($task, $task_num, $packet); $task_num = $self->_msg($user_or_socket, @message); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _msg { my($self, $user_or_socket, @message) = @_; my($message) = join('', @message); $message =~ s/\n/@{[HTLC_NEWLINE]}/osg; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($socket); if(ref($user_or_socket)) { $socket = $user_or_socket->socket() } else { $socket = $user_or_socket } my($data, $task_num); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_MSG); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len((SIZEOF_HL_SHORT_HDR * 2) + length($message)); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n6", 0x0002, # Num atoms HTLC_DATA_SOCKET, # Atom type 0x0002, # Atom length $socket, # Atom data HTLC_DATA_MSG, # Atom type length($message)) . # Atom length $message; # Atom data _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: MSG - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_SEND_MSG, time()); } else { return } return($task_num); } sub chat_action { my($self, @message) = @_; my($message) = join('', @message); $message =~ s/\n/@{[HTLC_NEWLINE]}/osg; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_CHAT); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len((SIZEOF_HL_SHORT_HDR * 2) + length($message)); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n6", 0x0002, # Num atoms HTLC_DATA_OPTION, # Atom type 0x0002, # Atom length 0x0001, # Atom data HTLC_DATA_CHAT, # Atom type length($message)) . # Atom length $message; # Atom data _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { return(1); } else { return } } sub chat { my($self, @message) = @_; my($message) = join('', @message); $message =~ s/\n/@{[HTLC_NEWLINE]}/osg; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_CHAT); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(SIZEOF_HL_SHORT_HDR + length($message)); $proto_header->len2($proto_header->len); $data = $proto_header->header() . pack("n3", 0x0001, # Num atoms HTLC_DATA_CHAT, # Atom type length($message)) . # Atom length $message; # Atom data _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { return(1); } else { return } } sub send_file { my($self, $task, $ref, $size, $resume) = @_; my($server, $port, $data, $xfer, $length, $buf_size); my($local_sep, $remote_sep, $filename, $src_path, $dest_path); my($type, $creator, $created, $modified, $finder_flags, $comments, $data_fh, $rsrc_fh, $data_len, $rsrc_len, $data_pos, $rsrc_pos, $res_fd); $task->finish(undef); $local_sep = PATH_SEPARATOR; $buf_size = $self->{'HTXF_BUFSIZE'}; if($resume) { # 52 46 4c 54 00 01 00 00 00 00 00 00 00 00 00 00 RFLT............ # 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ # 00 00 00 00 00 00 00 00 00 02 44 41 54 41 00 06 ..........DATA.. # 9a cf 00 00 00 00 00 00 00 00 4d 41 43 52 00 00 ..........MACR.. # 00 00 00 00 00 00 00 00 00 00 .......... unless(substr($resume, 0, 4) eq 'RFLT') { $task->error(1); $task->finish(time()); $task->error_text("Bad data from server!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } $data_pos = unpack("N", substr($resume, 46, 4)); $rsrc_pos = unpack("N", substr($resume, 62, 4)); } $data_fh = new IO::File; $rsrc_fh = new IO::File; ($src_path, $dest_path) = @{$task->path()}; ($filename = $src_path) =~ s/^.*?$local_sep([^$local_sep]+)$/$1/; ($data_len, $rsrc_len, $comments, $finder_flags, $type, $creator, $length) = @{$task->misc()}; unless($data_fh->open($src_path)) { $task->error(1); $task->finish(time()); $task->error_text("Could not open to $src_path: $!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } if($self->{'MACOS'}) { # Protect from compile-time errors on non-Mac OS systems that don't # define O_RSRC in Fcntl eval '$res_fd = POSIX::open($src_path, O_RDONLY | O_RSRC)'; unless($rsrc_fh->fdopen($res_fd, "r")) { $task->error(1); $task->finish(time()); $task->error_text("Could not read to resource fork from $src_path: $!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } } elsif($rsrc_len > 0 || ($resume && $rsrc_pos > 0)) { $task->error(1); $task->finish(time()); $task->error_text("Server is expecting resource fork data from a non-Mac OS client!\n" . "Are you sure you're uploading the right file?"); $self->{'LAST_ERROR'} = $task->error_text(); return; } if($resume) { if($rsrc_pos > 0) { unless($rsrc_fh->seek($rsrc_pos, 0)) { $task->error(1); $task->finish(time()); $task->error_text("Could not seek to position $rsrc_pos in resource fork of $src_path: $!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } } if($data_pos > 0) { unless($data_fh->seek($data_pos, 0)) { $task->error(1); $task->finish(time()); $task->error_text("Could not seek to position $data_pos in $src_path: $!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } } } ($created, $modified) = (stat($src_path))[9,10]; unless($self->{'MACOS'}) { $created += HTLC_UNIX_TO_MACOS_TIME; $modified += HTLC_UNIX_TO_MACOS_TIME; } $data = HTXF_MAGIC . pack("NNx4", $ref, ($length - $rsrc_pos - $data_pos)); $server = $self->{'SERVER_ADDR'}; # HTXF_TCPPORT only if server port is 5500 $port = $self->{'SERVER_PORT'} + 1; unless($xfer = IO::Socket::INET->new(PeerAddr =>$server, PeerPort =>$port, Timeout =>$self->{'CONNECT_TIMEOUT'}, Proto =>'tcp')) { $task->finish(time()); $task->error_text("Could not open file transfer connection: $@"); $self->{'LAST_ERROR'} = $task->error_text(); return; } _debug(_hexdump($data)); unless(_hlc_write($self, $xfer, \$data, length($data))) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text($self->{'LAST_ERROR'}); return; } # 46 49 4c 50 00 01 00 00 00 00 00 00 00 00 00 00 FILP............ # 00 00 00 00 00 00 00 03 49 4e 46 4f 00 00 00 00 ........INFO.... # 00 00 00 00 00 00 00 5c 41 4d 41 43 53 49 54 44 .......\AMACSITD # 53 49 54 21 00 00 00 00 00 00 21 00 00 00 00 00 SIT!......!..... # 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ # 00 00 00 00 00 00 00 00 00 00 00 00 00 07 70 00 ..............p. # 00 b1 ce 81 92 07 70 00 00 02 df 7d 3d 00 00 00 ......p....}=... # 12 53 77 6f 6f 70 20 46 41 51 2e 74 65 78 74 2e .Swoop FAQ.text. # 73 69 74 00 00 44 41 54 41 00 00 00 00 00 00 00 sit..DATA....... # 00 00 00 59 5c ...Y\ $data = pack("a4nx16na4x8Na4a4a4x6nx32nx2Nnx2NN", "FILP", 0x0001, 0x0003, "INFO", length($comments) + length($filename) + 74, "AMAC", $type, $creator, $finder_flags, 0x0770, $created, 0x0770, $modified, length($filename)); $data .= $filename . pack("n", length($comments)) . $comments . pack("a4x8N", "DATA", ($data_len - $data_pos)); _debug(_hexdump($data)); unless(_hlc_write($self, $xfer, \$data, length($data))) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text($self->{'LAST_ERROR'}); return; } # Upload data fork unless($self->_upload($xfer, $data_fh, $data_len, $buf_size)) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text("Upload did not complete."); } # 4D 41 43 52 00 00 00 00 00 00 00 00 00 00 01 EC MACR............ $data = pack("a4x8N", "MACR", ($rsrc_len - $rsrc_pos)); _debug(_hexdump($data)); unless(_hlc_write($self, $xfer, \$data, length($data))) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text($self->{'LAST_ERROR'}); return; } if($rsrc_len > 0) { # Upload resource fork unless($self->_upload($xfer, $rsrc_fh, $rsrc_len, $buf_size)) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text("Upload did not complete."); return; } } return(1); } sub recv_file { my($self, $task, $ref, $size) = @_; my($server, $data, $xfer, $tot_length, $length, $buf_size, @ret); my($data_file, $rsrc_file, $type, $creator, $created, $modified, $finder_flags, $comments, $comments_len, $data_fh, $data_len, $rsrc_fh, $rsrc_len, $name_len, $real_mac_res_fork, $res_fd, $finished_file, $port); $tot_length = $size; $buf_size = $self->{'HTXF_BUFSIZE'}; $data_fh = new IO::File; $rsrc_fh = new IO::File; ($data_file, $rsrc_file) = @{$task->path()}[1, 2]; if($self->{'MACOS'}) { if(length($data_file) > MACOS_MAX_FILENAME) { for($data_file) { my($len) = MACOS_MAX_FILENAME - 6; # Try to preserve filename extension, if any # ("\xC9" is "..." in Mac OS) # Otherwise, just truncate s/^(.{$len}).*?\.(\w{1,4})/$1\xC9.$2/o || s/^(.@{[MACOS_MAX_FILENAME]}).*/$1/; } } } unless($data_fh->open(">>$data_file")) { $task->error(1); $task->finish(time()); $task->error_text("Could not write to $data_file: $!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } if($self->{'MACOS'}) { # Protect from compile-time errors on non-Mac OS systems that don't # define O_RSRC in Fcntl eval '$res_fd = POSIX::open($data_file, O_WRONLY | O_CREAT | O_RSRC)'; } # If we're on Mac OS and we can write directly to the resource fork if(defined($res_fd) && $rsrc_fh->fdopen($res_fd, "w")) { $real_mac_res_fork = 1; # Temporarily set file type and creator to Hotline's "partial download" MacPerl::SetFileInfo(HTXF_PARTIAL_CREATOR, HTXF_PARTIAL_TYPE, $data_file); } else { unless($rsrc_fh->open(">>$rsrc_file")) { $task->error(1); $task->finish(time()); $task->error_text("Could not write to $rsrc_file: $!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } } $task->finish(undef); $server = $self->{'SERVER_ADDR'}; $data = HTXF_MAGIC . pack("Nx8", $ref); # HTXF_TCPPORT only if server port is 5500 $port = $self->{'SERVER_PORT'} + 1; unless($xfer = IO::Socket::INET->new(PeerAddr =>$server, PeerPort =>$port, Timeout =>$self->{'CONNECT_TIMEOUT'}, Proto =>'tcp')) { $task->finish(time()); $task->error_text("Could not open file transfer connection: $@"); $self->{'LAST_ERROR'} = $task->error_text(); return; } unless(_hlc_write($self, $xfer, \$data, length($data))) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text($self->{'LAST_ERROR'}); return; } # 46 49 4C 50 00 01 00 00 00 00 00 00 00 00 00 00 FILP............ # 00 00 00 00 00 00 00 03 49 4E 46 4F 00 00 00 00 ........INFO.... # 00 00 00 00 00 00 00 60 .......` unless(_hlc_buffered_read($self, $xfer, \$data, SIZEOF_HL_FILE_XFER_HDR)) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text($self->{'LAST_ERROR'}); return; } $tot_length -= SIZEOF_HL_FILE_XFER_HDR; $length = (unpack("N", substr($data, 36, 4)) + SIZEOF_HL_FILE_FORK_HDR); unless(substr($data, 0, 4) eq 'FILP') { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text("Bad data from server!"); $self->{'LAST_ERROR'} = $task->error_text(); return; } # 41 4D 41 43 54 45 58 54 AMACTEXT # 74 74 78 74 00 00 00 00 00 00 01 00 00 00 00 00 ttxt............ # 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ # 00 00 00 00 00 00 00 00 00 00 00 00 07 70 00 00 .............p.. # AE A3 8A 18 07 70 00 00 AE A3 8C 1D 00 00 00 05 .....p.......... # 74 65 78 74 32 00 11 66 74 70 2E 6D 69 63 72 6F text2..ftp.micro # 73 6F 66 74 2E 63 6F 6D 44 41 54 41 00 00 00 00 soft.comDATA.... # 00 00 00 00 00 00 01 00 ........ unless(_hlc_buffered_read($self, $xfer, \$data, $length)) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text($self->{'LAST_ERROR'}); return; } $tot_length -= $length; $type = substr($data, 4, 4); $creator = substr($data, 8, 4); $created = unpack("N", substr($data, 56, 4)); $finder_flags = substr($data, 18, 2); $modified = unpack("N", substr($data, 64, 4)); $name_len = unpack("C", substr($data, 71, 1)); $comments_len = unpack("n", substr($data, 72 + $name_len, 2)); # 72 $comments = substr($data, 72 + $name_len + 2, $comments_len); $data_len = unpack("N", substr($data, -4)); $length = $self->_download($xfer, $data_fh, $data_len, $buf_size); $tot_length -= $length; $data_fh->close(); unless($length == $data_len) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text("Download incomplete."); $self->{'LAST_ERROR'} = $task->error_text(); return; } # Yet another server bug: it'll tell you it's going to send a resource # fork header even when the file has no resource fork (i.e. $size will # be SIZEOF_HL_FILE_FORK_HDR bytes larger than the data the server will # actually send). So we only try to read if we have more than # SIZEOF_HL_FILE_FORK_HDR left. if($tot_length > SIZEOF_HL_FILE_FORK_HDR) { # 4D 41 43 52 00 00 00 00 00 00 00 00 00 00 01 EC MACR............ $length = _hlc_buffered_read($self, $xfer, \$data, SIZEOF_HL_FILE_FORK_HDR); return unless($length); $tot_length -= $length; $rsrc_len = unpack("N", substr($data, -4)); $length = $self->_download($xfer, $rsrc_fh, $rsrc_len, $buf_size); $tot_length -= $length; $rsrc_fh->close(); unless($length == $rsrc_len) { $xfer->close(); $task->error(1); $task->finish(time()); $task->error_text("Download incomplete."); $self->{'LAST_ERROR'} = $task->error_text(); return; } } else { $tot_length = 0; $rsrc_len = 0; } $xfer->close(); unless($tot_length == 0) { $task->error(1); $task->finish(time()); $task->error_text("Tried to download $size bytes, got " . $size - $tot_length . " bytes instead."); $self->{'LAST_ERROR'} = $task->error_text(); return; } $data_len = (stat($data_file))[7]; $rsrc_len = (stat($rsrc_file))[7]; unless($rsrc_len) { unlink($rsrc_file) if(-e $rsrc_file); undef $rsrc_file; $rsrc_len = 0; } unless($data_len || $real_mac_res_fork) { unlink($data_file) if(-e $data_file); undef $data_file; $data_len = 0; } $task->finish(time()); # Set the rest of the Mac OS information if we're doing that sort of thing if(($real_mac_res_fork && -e $data_file)) { utime($created, $modified, $data_file); my($fsspec) = MacPerl::MakeFSSpec($data_file); if(length($comments)) { Mac::MoreFiles::FSpDTSetComment($fsspec, $comments); } my($cat) = Mac::Files::FSpGetCatInfo($fsspec); my($finfo) = $cat->ioFlFndrInfo(); $finfo->fdFlags(unpack("n", $finder_flags) & 0xFEFF); $finfo->fdType($type); $finfo->fdCreator($creator); $cat->ioFlFndrInfo($finfo); Mac::Files::FSpSetCatInfo($fsspec, $cat); # Rename data file to remove the .data part ($finished_file = $data_file) =~ s/$self->{'DATA_FORK_EXT'}$//; unless(CORE::rename($data_file, $finished_file)) { $task->error_text(qq(Could not rename "$data_file" to "$finished_file": $!)); $self->{'LAST_ERROR'} = $task->error_text(); return; } # Return a sigle true value rather than an array of parameters # to indicate that you can't call macbinary() if we've already # made a Mac file. return(1); } elsif(! -e $rsrc_file) { ($finished_file = $data_file) =~ s/$self->{'DATA_FORK_EXT'}$//; CORE::rename($data_file, $finished_file); $data_file = $finished_file; } return [ $data_file, $data_len, $rsrc_file, $rsrc_len, $buf_size, $type, $creator, $comments, $created, $modified, $finder_flags ]; } sub _download { my($self, $src_fh, $dest_fh, $len, $buf_size) = @_; my($data, $tot_read, $read); $tot_read = 0; if($len <= $buf_size) { $read = read($src_fh, $data, $len); return unless(defined($read)); print $dest_fh $data || return; $tot_read += $read; } else { my($loop) = int($len/$buf_size); my($leftover) = $len % $buf_size; for(; $loop > 0; $loop--) { $read = read($src_fh, $data, $buf_size); return unless(defined($read)); print $dest_fh $data || return; $tot_read += $read; } if($leftover > 0) { $read = read($src_fh, $data, $leftover); return unless(defined($read)); print $dest_fh $data || return; $tot_read += $read; } } unless($tot_read == $len) { croak("Tried to read $len bytes, actually read $tot_read. Download may be corrupted!"); } return($tot_read); } sub _upload { my($self, $dest_fh, $src_fh, $len, $buf_size) = @_; my($data); if($len <= $buf_size) { unless(defined(read($src_fh, $data, $len))) { return } _hlc_write($self, $dest_fh, \$data, length($data)) || return; } else { my($loop) = int($len/$buf_size); my($leftover) = $len % $buf_size; for(; $loop > 0; $loop--) { unless(defined(read($src_fh, $data, $buf_size))) { return } _hlc_write($self, $dest_fh, \$data, length($data)) || return; } if($leftover > 0) { unless(defined(read($src_fh, $data, $leftover))) { return } _hlc_write($self, $dest_fh, \$data, length($data)) || return; } } return(1); } sub macbinary { my($self) = shift if(ref($_[0])); my($macbin_file, $params) = @_; unless(ref($params) =~ /^ARRAY/ && @{$params} == 11) { croak("Incorrect arguments to macbinary()"); } my($data_file, $data_len, $rsrc_file, $rsrc_len, $buf_size, $type, $creator, $comments, $created, $modified, $finder_flags) = @{$params}; my($finished_file, $filename, $macbin_fh, $data_fh, $rsrc_fh, $macbin_hdr, $buf, $len, $pad); unless($rsrc_len > 0 || $data_len > 0) { $self->{'LAST_ERROR'} = "No resource or data fork length." if($self); $! = "No resource or data fork length."; return; } if(defined($data_file)) { ($finished_file = $data_file) =~ s/$self->{'DATA_FORK_EXT'}$//; } elsif(defined($rsrc_file)) { ($finished_file = $rsrc_file) =~ s/$self->{'RSRC_FORK_EXT'}$//; } else { croak "Bad arguments to macbinary() - No rsrc or data file arguments."; } $finished_file =~ /([^@{[PATH_SEPARATOR]}]+)$/o; $filename = $1; unless(length($macbin_file)) { $macbin_file .= "$finished_file.bin"; } if(-e $macbin_file) { $self->{'LAST_ERROR'} = "$macbin_file: file already exists." if($self); $! = "$macbin_file: file already exists."; return; } $buf_size = 4096 unless($buf_size =~ /^\d+$/); $macbin_fh = new IO::File; $data_fh = new IO::File; $rsrc_fh = new IO::File; unless($macbin_fh->open(">$macbin_file")) { $self->{'LAST_ERROR'} = $! if($self); return; } $macbin_hdr = pack("x128"); # Start with empty 128 byte header # Offset 000-Byte, old version number, must be kept at zero for compatibility # Offset 001-Byte, Length of filename (must be in the range 1-63) substr($macbin_hdr, 1, 1) = pack("C", length($filename)); # Offset 002-1 to 63 chars, filename (only "length" bytes are significant). substr($macbin_hdr, 2, length($filename)) = $filename; # Offset 065-Long Word, file type (normally expressed as four characters) substr($macbin_hdr, 65, 4) = $type; # Offset 069-Long Word, file creator (normally expressed as four characters) substr($macbin_hdr, 69, 4) = $creator; # Offset 073-Byte, original Finder flags # Bit 7 - Locked. # Bit 6 - Invisible. # Bit 5 - Bundle. # Bit 4 - System. # Bit 3 - Bozo. # Bit 2 - Busy. # Bit 1 - Changed. # Bit 0 - Inited. substr($macbin_hdr, 73, 1) = # Clear inited bit pack("C", unpack("C", substr($finder_flags, 0, 1)) & 0xFE); # Offset 074-Byte, zero fill, must be zero for compatibility # Offset 075-Word, file's vertical position within its window. substr($macbin_hdr, 75, 2) = pack("n", 0xFFFF); # Offset 077-Word, file's horizontal position within its window. substr($macbin_hdr, 77, 2) = pack("n", 0xFFFF); # Offset 079-Word, file's window or folder ID. # Offset 081-Byte, "Protected" flag (in low order bit). # Offset 082-Byte, zero fill, must be zero for compatibility # Offset 083-Long Word, Data Fork length (bytes, zero if no Data Fork). substr($macbin_hdr, 83, 4) = pack("N", $data_len); # Offset 087-Long Word, Resource Fork length (bytes, zero if no R.F.). substr($macbin_hdr, 87, 4) = pack("N", $rsrc_len); # Offset 091-Long Word, File's creation date substr($macbin_hdr, 91, 4) = pack("N", $created); # Offset 095-Long Word, File's "last modified" date. substr($macbin_hdr, 95, 4) = pack("N", $modified); # Offset 099-Word, length of Get Info comment to be sent after the resource fork # (if implemented, see below). # Offset 101-Byte, Finder Flags, bits 0-7. (Bits 8-15 are already in byte 73) # Offset 116-Long Word, Length of total files when packed files are unpacked. # This is only used by programs that pack and unpack on the fly, # mimicing a standalone utility such as PackIt. A program that is # uploading a single file must zero this location when sending a # file. Programs that do not unpack/uncompress files when # downloading may ignore this value. substr($macbin_hdr, 116, 4) = pack("N", $data_len + $rsrc_len); # Offset 120-Word, Length of a secondary header. If this is non-zero, # Skip this many bytes (rounded up to the next multiple of 128) # This is for future expansion only, when sending files with # MacBinary, this word should be zero. # Offset 122-Byte, Version number of Macbinary II that the uploading program # is written for (the version begins at 129) substr($macbin_hdr, 122, 1) = pack("C", 129); # Offset 123-Byte, Minimum MacBinary II version needed to read this file # (start this value at 129 129) substr($macbin_hdr, 123, 1) = pack("C", 129); # Offset 124-Word, CRC of previous 124 bytes substr($macbin_hdr, 124, 2) = pack("n", macbin_crc(substr($macbin_hdr, 0, 124), 0)); # Macbinary II header print $macbin_fh $macbin_hdr; # Data fork, null padded to a multiple of 128 bytes if($data_len) { unless($data_fh->open($data_file)) { $self->{'LAST_ERROR'} = $! if($self); return; } while($len = read($data_fh, $buf, $buf_size)) { croak("read() error: $!") unless(defined($len)); print $macbin_fh $buf; } $data_fh->close(); if($data_len % 128) { $pad = "x" . (128 - ($data_len % 128)); print $macbin_fh pack($pad); } } # Resource fork, null padded to a multiple of 128 bytes if($rsrc_len) { unless($rsrc_fh->open($rsrc_file)) { $self->{'LAST_ERROR'} = $! if($self); return; } while($len = read($rsrc_fh, $buf, $buf_size)) { croak("read() error: $!") unless(defined($len)); print $macbin_fh $buf; } $rsrc_fh->close(); if($rsrc_len % 128) { $pad = "x" . (128 - ($rsrc_len % 128)); print $macbin_fh pack($pad); } } $macbin_fh->close(); return(1); } sub tracker { $_[0]->{'TRACKER_ADDR'} = $_[1] if(@_ == 2); return $_[0]->{'TRACKER_ADDR'}; } sub tracker_list { my($self, $timeout) = @_; my($tracker, $tracker_address, $server, $port, @servers, $data, $num_servers, $length, $tli_ip, $tli_port, $tli_num_users, $tli_name, $tli_desc, $byte1); $tracker_address = $self->{'TRACKER_ADDR'}; unless($tracker_address =~ /\S/) { croak("Tracker address not set!"); } if(($server = $tracker_address) =~ s/^([^ :]+)(?:[: ](\d+))?$/$1/) { $port = $2 || HTRK_TCPPORT; } else { croak("Bad server address: $tracker_address"); } $timeout = $self->{'CONNECT_TIMEOUT'} unless(defined($timeout)); eval { $SIG{'ALRM'} = sub { die "timeout" }; alarm($timeout); $tracker = IO::Socket::INET->new(PeerAddr =>$server, PeerPort =>$port, Timeout =>$timeout, Proto =>'tcp'); alarm(0); $SIG{'ALRM'} = 'DEFAULT'; }; if($@ =~ /timeout/) { $self->{'LAST_ERROR'} = "Timed out after $timeout seconds."; return; } if(!$tracker || $@) { $self->{'LAST_ERROR'} = $@ || $! || 'Connection failed'; return; } # 48 54 52 4B 00 01 HTRK.. _hlc_write($self, $tracker, \HTRK_MAGIC, HTRK_MAGIC_LEN) || return; # 48 54 52 4B 00 01 HTRK.. _hlc_buffered_read($self, $tracker, \$data, HTRK_MAGIC_LEN) || return; unless($data eq HTRK_MAGIC) { $self->{'LAST_ERROR'} = "Bad data from tracker. Not a hotline tracker?"; return; } # 00 01 1F F5 00 53 00 4A | D1 9C 4B 86 15 7C 00 04 .....S.J..K..|.. # ^^^^^^^^^^^ ^^^^^ ^^^^^ | ^^^^^^^^^^^ ^^^^^ ^^^^^ # ??????????? | ????? | IP Address Port num users ... # num servers | _hlc_buffered_read($self, $tracker, \$data, 8) || return; $num_servers = unpack("n", substr($data, 4, 2)); # Bug fixes here thanks to Les Brown while(@servers < $num_servers) { # 4 bytes for IP, 2 bytes for port, 2 bytes for num users unless(_hlc_buffered_read($self, $tracker, \$data, 4 + 2 + 2)) { $tracker->close() if($tracker->opened()); return unless(@servers); return (wantarray) ? @servers : \@servers; } # Skip these 8 bytes if the first byte was zero $byte1 = unpack("C", substr($data, 0, 1)); next if($byte1 == 0); $tli_ip = join('.', map { unpack("C", $_) } split('', substr($data, 0, 4))); $tli_port = unpack("n", substr($data, 4, 2)); $tli_num_users = unpack("n", substr($data, 6, 2)); # 2 null bytes, 1 byte for name len unless(_hlc_buffered_read($self, $tracker, \$data, 2 + 1)) { $tracker->close() if($tracker->opened()); return unless(@servers); return (wantarray) ? @servers : \@servers; } $length = unpack("C", substr($data, 2, 1)); # $length bytes for name, 1 byte for description length unless(_hlc_buffered_read($self, $tracker, \$data, $length + 1)) { $tracker->close() if($tracker->opened()); return unless(@servers); return (wantarray) ? @servers : \@servers; } $length = unpack("C", chop($tli_name = $data)); # $length bytes for description unless(_hlc_buffered_read($self, $tracker, \$tli_desc, $length)) { $tracker->close() if($tracker->opened()); return unless(@servers); return (wantarray) ? @servers : \@servers; } push(@servers, new Net::Hotline::TrackerListItem($tli_ip, $tli_port, $tli_num_users, $tli_name, $tli_desc)); } $tracker->close() if($tracker->opened()); return (wantarray) ? @servers : \@servers; } sub pchat_invite { my($self, $socket, $ref) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al11_pchat_invite_now($socket, $ref); } else { return $self->_pchat_invite($socket, $ref); } } sub _al11_pchat_invite_now { my($self, $socket, $ref) = @_; my($task, $task_num, $packet); $task_num = $self->_pchat_invite($socket, $ref); $task = $self->{'TASKS'}->{$task_num}; return(1) if(defined($ref)); return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _pchat_invite { my($self, $socket, $ref) = @_; my($data, $proto_header, $length, $task_num, $create); my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened()); $create = defined($ref); # 8 bytes for socket atom + 6 or 8 bytes for pchat ref atom (optional) $length = 8 + (defined($ref)) ? (($ref > 0xFFFF) ? 8 : 6) : 0; $proto_header = new Net::Hotline::Protocol::Header; $proto_header->type(($create) ? HTLC_HDR_PCHAT_CREATE : HTLC_HDR_PCHAT_INVITE); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len($length); $proto_header->len2($proto_header->len); $data = $proto_header->header(); # Socket of the user we're inviting $data .= pack("nnnn", ($create) ? 2 : 1, # Num atoms HTLC_DATA_SOCKET, # Atom type 0x0002, # Atom length $socket); # Atom value unless($create) { my($fmt) = ($ref > 0xFFFF) ? "nnN" : "nnn"; # Private chat reference number $data .= pack($fmt, HTLC_DATA_PCHAT_REF, # Atom type ($ref > 0xFFFF) ? 4 :2,# Atom length $ref); # Atom value } _debug(_hexdump($data)); $task_num = $proto_header->seq(); if($create) { if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: PCHAT INVITE/CREATE - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num,HTLC_TASK_PCHAT_CREATE, time()); } else { return } return($task_num); } else { if(_hlc_write($self, $server, \$data, length($data))) { _debug("PCHAT INVITE SOCKET($socket) TO PCHAT($ref)\n"); return(1); } else { return } } } sub pchat_accept { my($self, $ref) = @_; if($self->{'BLOCKING_TASKS'}) { return $self->_al12_pchat_accept_now($ref); } else { return $self->_pchat_accept($ref); } } sub _al12_pchat_accept_now { my($self, $ref) = @_; my($task, $task_num, $packet); $task_num = $self->_pchat_accept($ref); $task = $self->{'TASKS'}->{$task_num}; return unless($task_num); $packet = _blocking_task($self, $task_num); if($task->error()) { $self->{'LAST_ERROR'} = $task->error_text(); return; } return(1); } sub _pchat_accept { my($self, $ref) = @_; my($data, $proto_header, $task_num); my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && defined($ref)); $proto_header = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_PCHAT_ACCEPT); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(($ref > 0xFFFF) ? 10 : 8); $proto_header->len2($proto_header->len); $data = $proto_header->header(); my($fmt) = ($ref > 0xFFFF) ? "nnnN" : "nnnn"; # Pchat ref number atom $data .= pack($fmt, 0x0001, # Num atoms HTLC_DATA_PCHAT_REF, # Atom type ($ref > 0xFFFF) ? 4 : 2,# Atom length $ref); # Atom value _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { _debug("NEW TASK: PCHAT ACCEPT($ref) - $task_num\n"); $self->{'TASKS'}->{$task_num} = new Net::Hotline::Task($task_num, HTLC_TASK_PCHAT_ACCEPT, time(), undef, undef, $ref); } else { return } return($task_num); } sub pchat_decline { my($self, $ref) = @_; my($data, $proto_header, $task_num, $length); my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && defined($ref)); $proto_header = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_PCHAT_DECLINE); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(($ref > 0xFFFF) ? 10 : 8); $proto_header->len2($proto_header->len); $data = $proto_header->header(); my($fmt) = ($ref > 0xFFFF) ? "nnnN" : "nnnn"; # Pchat ref number atom $data .= pack($fmt, 0x0001, # Num atoms HTLC_DATA_PCHAT_REF, # Atom type ($ref > 0xFFFF) ? 4 : 2,# Atom length $ref); # Atom value _debug(_hexdump($data)); $task_num = $proto_header->seq(); if(_hlc_write($self, $server, \$data, length($data))) { return(1); } else { return } } sub al07_pchat_action { my($self, $ref, @message) = @_; my($message) = join('', @message); $message =~ s/\n/@{[HTLC_NEWLINE]}/osg; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && defined($ref)); my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_CHAT); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len((($ref > 0xFFFF) ? 20 : 18) + length($message)); $proto_header->len2($proto_header->len); my($fmt) = ($ref > 0xFFFF) ? "n6Nnn" : "n9"; $data = $proto_header->header() . pack($fmt, 0x0003, # Num atoms HTLC_DATA_OPTION, # Atom type 0x0002, # Atom length 0x0001, # Atom data HTLC_DATA_PCHAT_REF, # Atom type ($ref > 0xFFFF) ? 4 : 2, # Atom length $ref, # Atom value HTLC_DATA_CHAT, # Atom type length($message)) . # Atom length $message; # Atom data _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { return(1); } else { return } } sub pchat { my($self, $ref, @message) = @_; my($message) = join('', @message); $message =~ s/\n/@{[HTLC_NEWLINE]}/osg; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && defined($ref)); my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_CHAT); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len((($ref > 0xFFFF) ? 14 : 12) + length($message)); $proto_header->len2($proto_header->len); my($fmt) = ($ref > 0xFFFF) ? "n3Nnn" : "n6"; $data = $proto_header->header() . pack($fmt, 0x0002, # Num atoms HTLC_DATA_PCHAT_REF, # Atom type ($ref > 0xFFFF) ? 4 : 2, # Atom length $ref, # Atom value HTLC_DATA_CHAT, # Atom type length($message)) . # Atom length $message; # Atom data _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { return(1); } else { return } } sub pchat_leave { my($self, $ref) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && defined($ref)); my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_PCHAT_CLOSE); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len(($ref > 0xFFFF) ? 10 : 8); $proto_header->len2($proto_header->len); my($fmt) = ($ref > 0xFFFF) ? "n3N" : "n4"; $data = $proto_header->header() . pack($fmt, 0x0001, # Num atoms HTLC_DATA_PCHAT_REF, # Atom type ($ref > 0xFFFF) ? 4 : 2, # Atom length $ref); # Atom value _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { delete $self->{'PCHATS'}->{$ref}; return(1); } else { return } } sub pchat_subject { my($self, $ref, @subject) = @_; my($server) = $self->{'SERVER'} or croak "Not connected to a server"; return unless($server->opened() && defined($ref)); my($subject) = join('', @subject); my($data); my($proto_header) = new Net::Hotline::Protocol::Header; $proto_header->type(HTLC_HDR_PCHAT_SUBJECT); $proto_header->seq($self->_next_seqnum()); $proto_header->task(0x00000000); $proto_header->len((($ref > 0xFFFF) ? 14 : 12) + length($subject)); $proto_header->len2($proto_header->len); my($fmt) = ($ref > 0xFFFF) ? "n3Nnn" : "n6"; $data = $proto_header->header() . pack($fmt, 0x0002, # Num atoms HTLC_DATA_PCHAT_REF, # Atom type ($ref > 0xFFFF) ? 4 : 2, # Atom length $ref, # Atom value HTLC_DATA_PCHAT_SUBJECT, # Atom type length($subject)) . # Atom length $subject; # Atom value _debug(_hexdump($data)); if(_hlc_write($self, $server, \$data, length($data))) { return(1); } else { return } } 1; $tli_port, $tli_num_users, Net-Hotline-0.83/lib/Net/Hotline/PrivateChat.pm010064400427010022003000000016310757122347300224340ustar00macintshalumni00000400000004package Net::Hotline::PrivateChat; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); $VERSION = '0.80'; sub new { my($class, @args) = @_; my($self); if(@args) { $self = { 'REFERENCE' => $args[0], 'USER_LIST' => $args[1], 'SUBJECT' => $args[2] }; } else { $self = { 'REFERENCE' => undef, 'USER_LIST' => undef, 'SUBJECT' => undef }; } bless $self, $class; return $self; } sub reference { $_[0]->{'REFERENCE'} = $_[1] if(@_ == 2); return $_[0]->{'REFERENCE'}; } sub userlist { $_[0]->{'USER_LIST'} = $_[1] if(@_ == 2); return $_[0]->{'USER_LIST'}; } sub subject { $_[0]->{'SUBJECT'} = $_[1] if(@_ == 2); return $_[0]->{'SUBJECT'}; } 1; Net-Hotline-0.83/lib/Net/Hotline/Constants.pm010064400427010022003000000246400757122347000222000ustar00macintshalumni00000400000004package Net::Hotline::Constants; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $VERSION %HTLC_COLORS); $VERSION = '0.80'; require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw( HTLC_CHECKBYTES HTLC_COLORS HTLC_DATA_BAN HTLC_DATA_CHAT HTLC_DATA_DESTDIR HTLC_DATA_DIRECTORY HTLC_DATA_FILE HTLC_DATA_FILE_RENAME HTLC_DATA_HTXF_SIZE HTLC_DATA_ICON HTLC_DATA_LOGIN HTLC_DATA_MSG HTLC_DATA_NEWS_POST HTLC_DATA_NICKNAME HTLC_DATA_OPTION HTLC_DATA_PASSWORD HTLC_DATA_PCHAT_REF HTLC_DATA_PCHAT_SUBJECT HTLC_DATA_RFLT HTLC_DATA_SOCKET HTLC_DEFAULT_ICON HTLC_DEFAULT_LOGIN HTLC_DEFAULT_NICK HTLC_EWOULDBLOCK HTLC_FOLDER_TYPE HTLC_HDR_CHAT HTLC_HDR_FILE_DELETE HTLC_HDR_FILE_GET HTLC_HDR_FILE_GETINFO HTLC_HDR_FILE_LIST HTLC_HDR_FILE_MKDIR HTLC_HDR_FILE_MOVE HTLC_HDR_FILE_PUT HTLC_HDR_FILE_SETINFO HTLC_HDR_LOGIN HTLC_HDR_MSG HTLC_HDR_NEWS_GETFILE HTLC_HDR_NEWS_POST HTLC_HDR_PCHAT_ACCEPT HTLC_HDR_PCHAT_CLOSE HTLC_HDR_PCHAT_CREATE HTLC_HDR_PCHAT_DECLINE HTLC_HDR_PCHAT_INVITE HTLC_HDR_PCHAT_SUBJECT HTLC_HDR_USER_CHANGE HTLC_HDR_USER_CREATE HTLC_HDR_USER_GETINFO HTLC_HDR_USER_GETLIST HTLC_HDR_USER_KICK HTLC_HDR_USER_OPEN HTLC_INFO_FALIAS_TYPE HTLC_INFO_FOLDER_TYPE HTLC_MACOS_TO_UNIX_TIME HTLC_MAGIC HTLC_MAGIC_LEN HTLC_MAX_PATHLEN HTLC_NEWLINE HTLC_PATH_SEPARATOR HTLC_TASK_BAN HTLC_TASK_FILE_DELETE HTLC_TASK_FILE_GET HTLC_TASK_FILE_INFO HTLC_TASK_FILE_LIST HTLC_TASK_FILE_MKDIR HTLC_TASK_FILE_MOVE HTLC_TASK_FILE_PUT HTLC_TASK_KICK HTLC_TASK_LOGIN HTLC_TASK_NEWS HTLC_TASK_NEWS_POST HTLC_TASK_PCHAT_ACCEPT HTLC_TASK_PCHAT_CREATE HTLC_TASK_SEND_MSG HTLC_TASK_SET_INFO HTLC_TASK_USER_INFO HTLC_TASK_USER_LIST HTLC_UNIX_TO_MACOS_TIME HTLS_DATA_AGREEMENT HTLS_DATA_CHAT HTLS_DATA_COLOR HTLS_DATA_FILE_COMMENT HTLS_DATA_FILE_CREATOR HTLS_DATA_FILE_CTIME HTLS_DATA_FILE_ICON HTLS_DATA_FILE_LIST HTLS_DATA_FILE_MTIME HTLS_DATA_FILE_NAME HTLS_DATA_FILE_SIZE HTLS_DATA_FILE_TYPE HTLS_DATA_HTXF_REF HTLS_DATA_HTXF_SIZE HTLS_DATA_ICON HTLS_DATA_MSG HTLS_DATA_NEWS HTLS_DATA_NEWS_POST HTLS_DATA_NICKNAME HTLS_DATA_PCHAT_REF HTLS_DATA_PCHAT_SUBJECT HTLS_DATA_SERVER_MSG HTLS_DATA_SOCKET HTLS_DATA_TASK_ERROR HTLS_DATA_USER_INFO HTLS_DATA_USER_LIST HTLS_HDR_AGREEMENT HTLS_HDR_CHAT HTLS_HDR_MSG HTLS_HDR_NEWS_POST HTLS_HDR_PCHAT_INVITE HTLS_HDR_PCHAT_SUBJECT HTLS_HDR_PCHAT_USER_JOIN HTLS_HDR_PCHAT_USER_LEAVE HTLS_HDR_POLITE_QUIT HTLS_HDR_TASK HTLS_HDR_USER_CHANGE HTLS_HDR_USER_LEAVE HTLS_MAGIC HTLS_MAGIC_LEN HTLS_TCPPORT HTRK_MAGIC HTRK_MAGIC_LEN HTRK_TCPPORT HTRK_UDPPORT HTXF_BUFSIZE HTXF_MAGIC HTXF_MAGIC_LEN HTXF_PARTIAL_CREATOR HTXF_PARTIAL_TYPE HTXF_RESUME_MAGIC HTXF_RFLT_MAGIC HTXF_TCPPORT PATH_SEPARATOR SIZEOF_HL_DATA_HDR SIZEOF_HL_FILE_FORK_HDR SIZEOF_HL_FILE_LIST_HDR SIZEOF_HL_FILE_UPLOAD_HDR SIZEOF_HL_FILE_XFER_HDR SIZEOF_HL_LONG_HDR SIZEOF_HL_PROTO_HDR SIZEOF_HL_SHORT_HDR SIZEOF_HL_TASK_FILLER SIZEOF_HL_USER_LIST_HDR MACOS_MAX_FILENAME HTLS_DATA_REPLY HTLS_DATA_IS_REPLY); %EXPORT_TAGS = ('all' => \@EXPORT_OK); use constant PATH_SEPARATOR => ($^O eq 'MacOS') ? ':' : '/'; %HTLC_COLORS = (0 => 'gray', 1 => 'black', 2 => 'red', 3 => 'pink'); # Hotline gives times relative to Mac OS epoch. Add this constant to the # times returned by Hotline to get the time since the unix epoch. use constant HTLC_MACOS_TO_UNIX_TIME => -2082830400; # Add this constant to Unix times to get Hotline (Mac OS) times use constant HTLC_UNIX_TO_MACOS_TIME => 2082830400; use constant HTLC_PATH_SEPARATOR => ':'; use constant HTLC_FOLDER_TYPE => 'fldr'; use constant HTXF_PARTIAL_TYPE => 'HTft'; use constant HTXF_PARTIAL_CREATOR => 'HTLC'; use constant HTLC_INFO_FOLDER_TYPE => 'Folder'; use constant HTLC_INFO_FALIAS_TYPE => 'Folder Alias'; use constant HTLC_DEFAULT_NICK => 'guest'; use constant HTLC_DEFAULT_LOGIN => 'guest'; use constant HTLC_DEFAULT_ICON => 410; use constant HTLC_EWOULDBLOCK => 2; # Can be anything > 1, really use constant HTLC_MAX_PATHLEN => 255; use constant MACOS_MAX_FILENAME => 31; # Arbitrary unique task type constants use constant HTLC_TASK_FILE_DELETE => 1; use constant HTLC_TASK_FILE_GET => 2; use constant HTLC_TASK_FILE_INFO => 3; use constant HTLC_TASK_FILE_LIST => 4; use constant HTLC_TASK_FILE_MKDIR => 5; use constant HTLC_TASK_FILE_MOVE => 6; use constant HTLC_TASK_FILE_PUT => 7; use constant HTLC_TASK_KICK => 8; use constant HTLC_TASK_LOGIN => 9; use constant HTLC_TASK_NEWS => 10; use constant HTLC_TASK_NEWS_POST => 11; use constant HTLC_TASK_SEND_MSG => 12; use constant HTLC_TASK_SET_INFO => 13; use constant HTLC_TASK_USER_INFO => 14; use constant HTLC_TASK_USER_LIST => 15; use constant HTLC_TASK_PCHAT_CREATE => 16; use constant HTLC_TASK_PCHAT_ACCEPT => 17; use constant HTLC_TASK_BAN => 18; use constant HTRK_TCPPORT => 5498; use constant HTRK_UDPPORT => 5499; use constant HTLS_TCPPORT => 5500; use constant HTXF_TCPPORT => 5501; use constant HTXF_BUFSIZE => 4096; use constant HTLC_NEWLINE => "\015"; use constant HTLC_MAGIC => pack("C12", 84, 82, 84, 80, 72, 79, 84, 76, 0, 1, 0, 2); use constant HTLC_MAGIC_LEN => 12; use constant HTLS_MAGIC => pack("C8", 84, 82, 84, 80, 0, 0, 0, 0); use constant HTLS_MAGIC_LEN => 8; use constant HTRK_MAGIC => pack("C6", 72, 84, 82, 75, 0, 1); use constant HTRK_MAGIC_LEN => 6; use constant HTXF_MAGIC => pack("C4", 72, 84, 88, 70); use constant HTXF_MAGIC_LEN => 4; use constant HTXF_RFLT_MAGIC => pack("C4", 82, 70, 76, 84); use constant HTXF_RESUME_MAGIC => pack("n3", 0x00CC, 0x0002, 0x0001); use constant HTLC_HDR_CHAT => 0x00000069; use constant HTLC_HDR_FILE_DELETE => 0x000000CC; use constant HTLC_HDR_FILE_GET => 0x000000CA; use constant HTLC_HDR_FILE_GETINFO => 0x000000CE; use constant HTLC_HDR_FILE_LIST => 0x000000C8; use constant HTLC_HDR_FILE_MKDIR => 0x000000CD; use constant HTLC_HDR_FILE_MOVE => 0x000000D0; use constant HTLC_HDR_FILE_PUT => 0x000000CB; use constant HTLC_HDR_FILE_SETINFO => 0x000000CF; use constant HTLC_HDR_LOGIN => 0x0000006B; use constant HTLC_HDR_MSG => 0x0000006C; use constant HTLC_HDR_NEWS_GETFILE => 0x00000065; use constant HTLC_HDR_NEWS_POST => 0x00000067; use constant HTLC_HDR_PCHAT_ACCEPT => 0x00000073; use constant HTLC_HDR_PCHAT_CLOSE => 0x00000074; use constant HTLC_HDR_PCHAT_CREATE => 0x00000070; use constant HTLC_HDR_PCHAT_DECLINE => 0x00000072; use constant HTLC_HDR_PCHAT_INVITE => 0x00000071; use constant HTLC_HDR_PCHAT_SUBJECT => 0x00000078; use constant HTLC_HDR_USER_CHANGE => 0x00000130; use constant HTLC_HDR_USER_CREATE => 0x0000015E; use constant HTLC_HDR_USER_GETINFO => 0x0000012F; use constant HTLC_HDR_USER_GETLIST => 0x0000012C; use constant HTLC_HDR_USER_KICK => 0x0000006E; use constant HTLC_HDR_USER_OPEN => 0x00000160; use constant HTLC_DATA_BAN => 0x0071; use constant HTLC_DATA_CHAT => 0x0065; use constant HTLC_DATA_DESTDIR => 0x00D4; use constant HTLC_DATA_DIRECTORY => 0x00CA; use constant HTLC_DATA_FILE => 0x00C9; use constant HTLC_DATA_FILE_RENAME => 0x00D3; use constant HTLC_DATA_HTXF_SIZE => 0x006C; use constant HTLC_DATA_ICON => 0x0068; use constant HTLC_DATA_LOGIN => 0x0069; use constant HTLC_DATA_MSG => 0x0065; use constant HTLC_DATA_NEWS_POST => 0x0065; use constant HTLC_DATA_NICKNAME => 0x0066; use constant HTLC_DATA_OPTION => 0x006D; use constant HTLC_DATA_PASSWORD => 0x006A; use constant HTLC_DATA_PCHAT_REF => 0x0072; use constant HTLC_DATA_PCHAT_SUBJECT => 0x0073; use constant HTLC_DATA_RFLT => 0x00CB; use constant HTLC_DATA_SOCKET => 0x0067; use constant HTLS_HDR_AGREEMENT => 0x0000006D; use constant HTLS_HDR_CHAT => 0x0000006A; use constant HTLS_HDR_MSG => 0x00000068; use constant HTLS_HDR_NEWS_POST => 0x00000066; use constant HTLS_HDR_PCHAT_INVITE => 0x00000071; use constant HTLS_HDR_PCHAT_SUBJECT => 0x00000077; use constant HTLS_HDR_PCHAT_USER_JOIN => 0x00000075; use constant HTLS_HDR_PCHAT_USER_LEAVE => 0x00000076; use constant HTLS_HDR_POLITE_QUIT => 0x0000006F; use constant HTLS_HDR_TASK => 0x00010000; use constant HTLS_HDR_USER_CHANGE => 0x0000012D; use constant HTLS_HDR_USER_LEAVE => 0x0000012E; use constant HTLS_DATA_AGREEMENT => 0x0065; use constant HTLS_DATA_CHAT => 0x0065; use constant HTLS_DATA_COLOR => 0x0070; use constant HTLS_DATA_REPLY => 0x00D6; use constant HTLS_DATA_IS_REPLY => 0x0071; use constant HTLS_DATA_ICON => 0x0068; use constant HTLS_DATA_NEWS => 0x0065; use constant HTLS_DATA_NICKNAME => 0x0066; use constant HTLS_DATA_SERVER_MSG => 0x006D; use constant HTLS_DATA_SOCKET => 0x0067; use constant HTLS_DATA_TASK_ERROR => 0x0064; use constant HTLS_DATA_USER_INFO => 0x0065; use constant HTLS_DATA_USER_LIST => 0x012C; use constant HTLS_DATA_FILE_COMMENT => 0x00D2; use constant HTLS_DATA_FILE_CREATOR => 0x00CE; use constant HTLS_DATA_FILE_CTIME => 0x00D0; use constant HTLS_DATA_FILE_ICON => 0x00D5; use constant HTLS_DATA_FILE_LIST => 0x00C8; use constant HTLS_DATA_FILE_MTIME => 0x00D1; use constant HTLS_DATA_FILE_NAME => 0x00C9; use constant HTLS_DATA_FILE_SIZE => 0x00CF; use constant HTLS_DATA_FILE_TYPE => 0x00CD; use constant HTLS_DATA_HTXF_REF => 0x006B; use constant HTLS_DATA_HTXF_SIZE => 0x006C; use constant HTLS_DATA_MSG => 0x0065; use constant HTLS_DATA_NEWS_POST => 0x0065; use constant HTLS_DATA_PCHAT_REF => 0x0072; use constant HTLS_DATA_PCHAT_SUBJECT => 0x0073; use constant SIZEOF_HL_PROTO_HDR => 20; use constant SIZEOF_HL_DATA_HDR => 4; use constant SIZEOF_HL_SHORT_HDR => 6; use constant SIZEOF_HL_LONG_HDR => 8; use constant SIZEOF_HL_FILE_LIST_HDR => 24; use constant SIZEOF_HL_USER_LIST_HDR => 12; use constant SIZEOF_HL_TASK_FILLER => 2; use constant SIZEOF_HL_FILE_XFER_HDR => 40; use constant SIZEOF_HL_FILE_UPLOAD_HDR => 111; use constant SIZEOF_HL_FILE_FORK_HDR => 16; 1; N HTLC_DATA_CHAT HTLC_DATA_DESTDIR HTLC_DATA_DIRECTORY HTLC_DATA_FILE HTLC_DATA_FILE_RENAME HTLCNet-Hotline-0.83/lib/Net/Hotline/User.pod010064400427010022003000000036600757122347400213130ustar00macintshalumni00000400000004=head1 NAME Net::Hotline::User - User object used internally by Net::Hotline::Client =head1 SYNOPSIS use Net::Hotline::User; $user = new Net::Hotline::User; $user->nick("joe blow"); $user->icon(128); print "Nick: ", $user->nick(), "\n"; ... =head1 DESCRIPTION Net::Hotline::User is a simple class for storing and retrieving user information, You should never have to create your own Net::Hotline::User objects when using Net::Hotline::Client. Getting and setting attributes is all that should be necessary. =head1 CONSTRUCTION =over 4 =item new SOCKET, NICK, LOGIN, ICON, COLOR With no arguments, creates a new Net::Hotline::User object with all attributes set to undef. The other option is to supply exactly 5 arguments as listed above. =back =head1 METHODS All the Net::Hotline::User methods are simple attribute get/set routines. If given an argument, they set an attribute. In all cases, they return the current value of the attribute. =over 4 =item color NUMBER The color of the user in the userlist. Values are numbers from 0 to 3. The hash HTLC_COLORS defined in Net::Hotline::Constants contains number to name color mappings (i.e. $HTLC_COLORS{2} is "red"). Example: use Net::Hotline::Constants qw(HTLC_COLORS); ... print $user->nick(), " is ", $HTLC_COLORS{$user->color()}, "\n"; =item icon NUMBER The user's icon number. Negative values are accepted. =item info TEXT User information as a block of "pretty-formatted" text. =item login TEXT The user's login name. =item nick TEXT The user's nickname in the userlist. =item socket NUMBER The user's unique socket number. User's are assigned a socket number whenthey connect to a Hotline server. =back =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Hotline-0.83/lib/Net/Hotline/FileInfoItem.pm010064400427010022003000000023260757122347200225350ustar00macintshalumni00000400000004package Net::Hotline::FileInfoItem; ## Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. use strict; use vars qw($VERSION); $VERSION = '0.80'; sub new { my($class) = shift; my($self) = { 'ICON' => undef, 'TYPE' => undef, 'CREATOR' => undef, 'SIZE' => undef, 'NAME' => undef, 'COMMENT' => undef, 'CTIME' => undef, 'MTIME' => undef }; bless $self, $class; return $self; } sub icon { $_[0]->{'TYPE'} = $_[1] if(@_ == 2); return $_[0]->{'TYPE'}; } sub type { $_[0]->{'TYPE'} = $_[1] if(@_ == 2); return $_[0]->{'TYPE'}; } sub creator { $_[0]->{'CREATOR'} = $_[1] if(@_ == 2); return $_[0]->{'CREATOR'}; } sub size { $_[0]->{'SIZE'} = $_[1] if(@_ == 2); return $_[0]->{'SIZE'}; } sub name { $_[0]->{'NAME'} = $_[1] if(@_ == 2); return $_[0]->{'NAME'}; } sub comment { $_[0]->{'COMMENT'} = $_[1] if(@_ == 2); return $_[0]->{'COMMENT'}; } sub ctime { $_[0]->{'CTIME'} = $_[1] if(@_ == 2); return $_[0]->{'CTIME'}; } sub mtime { $_[0]->{'MTIME'} = $_[1] if(@_ == 2); return $_[0]->{'MTIME'}; } 1; Net-Hotline-0.83/lib/Net/Hotline.pm010064400427010022003000000004040757122346000202130ustar00macintshalumni00000400000004package Net::Hotline; # Provides the version number for the whole set of Net::Hotline:: libs. # Currently, this includes only the Net::Hotline::Client $VERSION = '0.83'; # The client module is loaded when you "use Net::Hotline" use Net::Hotline::Client; 1; Net-Hotline-0.83/lib/Net/Hotline.pod010064400427010022003000000011250757122346100203630ustar00macintshalumni00000400000004=head1 NAME Net::Hotline - Perl libraries for the Hotline internet client =head1 SYNOPSIS use Net::Hotline; =head1 DESCRIPTION The Net::Hotline module simply loads Net::Hotline::Client. For more information on the Net::Hotline::Client module, please see its documentation. For more information on Hotline, see http://www.hotlinesw.com/ =head1 AUTHOR John C. Siracusa (siracusa@mindspring.com) =head1 COPYRIGHT Copyright(c) 1999 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Hotline-0.83/README010064400427010022003000000047570757122344200156560ustar00macintshalumni00000400000004DESCRIPTION The Net::Hotline modules implement a Hotline interface in Perl. Currently, this includes only Net::Hotline::Client. Hotline is an internet client/server system that's sort of a cross between IRC and a traditional BBS. See http://www.hotlinesw.com/ for more information. PREREQUISITES Net::Hotline has been tested with perl version 5.6.1, MacPerl 5.2.0r4, and Hotline server versions 1.2.1 and 1.2.3. It should work fine on any version of Perl 5 and any 1.2.x version of Hotline, however. INSTALLATION The standard incantations should work: perl Makefile.PL make make install Here are a few common variations on that theme: * If you don't want to (or can't) install in the system-wide directories, you can use PREFIX to install elsewhere. Example: perl Makefile.PL PREFIX=~/perl make make install You'll probably have to create some dummy directories before this works. Just look at the error messages and create the directories it says it can't find. * If you're installing on a classic Mac OS system, simply duplicate the folder hierarchy inside the distribution's "lib" folder in your MacPerl folder. For example, "lib/Net/Hotline/Protocol/Packet.pm" would be copied to "/lib/Net/Hotline/Protocol/Packet.pm" (You'll have to create any nonexistent folders in the path) I'm not sure how to AutoSplit in MacPerl, so what I've been doing is commenting out three lines in "Client.pm" to disable AutoLoading. The lines are: 31: use AutoLoader 'AUTOLOAD'; 1488: __END__ Just add a "#" character to the beginning of those lines. EXAMPLES There are two example scripts in the "Examples" directory. 1. "hlftp.pl" is a simple command line FTP-like Hotline client included to demonstrate Net::Hotline::Client's "blocking task mode" (read the documentation for an explanation). Its operation should be familiar to anyone who's used ncftp or the regular Unix ftp client. 2. "hibot.pl" is a very simple Hotline "bot" included to demonstrate Net::Hotline::Client's "event loop mode" (again, RTFM). It works a lot like hlftp.pl in terms of connecting to servers. Log the bot onto your local Hotline server an message it with the text "help" for more information. BUG REPORTING Send bug reports to John C. Siracusa (siracusa@mindspring.com) COPYRIGHT Copyright(c) 1998-2002 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. , however. INSTANet-Hotline-0.83/MANIFEST010064400427010022003000000012520757122343700161160ustar00macintshalumni00000400000004Changes Makefile.PL MANIFEST README TODO lib/Net/Hotline/Protocol/Header.pm lib/Net/Hotline/Protocol/Packet.pm lib/Net/Hotline/Client.pm lib/Net/Hotline/Client.pod lib/Net/Hotline/Constants.pm lib/Net/Hotline/FileInfoItem.pm lib/Net/Hotline/FileInfoItem.pod lib/Net/Hotline/FileListItem.pm lib/Net/Hotline/FileListItem.pod lib/Net/Hotline/PrivateChat.pm lib/Net/Hotline/PrivateChat.pod lib/Net/Hotline/Shared.pm lib/Net/Hotline/Task.pm lib/Net/Hotline/Task.pod lib/Net/Hotline/TrackerListItem.pm lib/Net/Hotline/TrackerListItem.pod lib/Net/Hotline/User.pm lib/Net/Hotline/User.pod lib/Net/Hotline.pm lib/Net/Hotline.pod t/basic.t Examples/hibot.pl Examples/hlftp.pl Examples/README Net-Hotline-0.83/Examples/004070000427010022003000000000000757122352600165335ustar00macintshalumni00000400000004Net-Hotline-0.83/Examples/hibot.pl010064400427010022003000000212030757122344400202010ustar00macintshalumni00000400000004#!/usr/local/bin/perl ## Copyright(c) 1998-1999 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. ## ## hibot.pl - A simple hotline bot by John Siracusa, created to ## demonstrate the Net::Hotline::Client module's event mode. ## ## Created: July 17th, 1998 ## Modified: June 7th, 1999 ## use strict; use IO::File; use Getopt::Std; use Net::Hotline::Client; use Net::Hotline::Constants qw(HTLC_MACOS_TO_UNIX_TIME); my($hlc, %OPT, $SLEEPING, $ICON_SAVE); getopts('hD', \%OPT); &Usage if($OPT{'h'}); my $MACOS = ($^O eq 'MacOS'); ## ## Handler prototypes ## # Events sub Chat_Handler; sub Msg_Handler; sub Join_Handler; ## ## Defaults ## my $DEF_ICON = 410; my $DEF_LOGIN = 'guest'; my $DEF_NICK = 'hibot'; my $DEF_PASSWORD = ''; ## ## Bot identity ## my $BOT_NICK = 'hibot'; my $BOT_NICK_ABBREV = 'hb'; my $PROPER_BOT_NICK = $BOT_NICK; ## ## Misc. settings ## my $ABSORB_EVENTS = -1; # Don't initially absorb any events my $SLEEP_IDLE_SECS = 10; # Seconds of idle time before sleeping my $ICON_SLEEP = -414; # Sleep icon resource id my @GREETINGS = qw(Hello Hi Hey Greetings Howdy); my @EIGHTBALL = ("Most likely.", "As I see it, yes.", "It is decidedly so.", "Outlook good.", "My sources say no.", "Outook not so good.", "Concentrate and ask again.", "Yes, definitely.", "Without a doubt.", "Signs point to yes.", "Better not tell you now.", "You may rely on it.", "My reply is no.", "Very doubtful.", "It is certain.", "Ask again later.", "Yes.", "Reply hazy, try again.", "Cannot predict now.", "Don't count on it."); ## ## Main function ## MAIN: { my($nick, $login, $password, $server, $icon, $port); $nick = $DEF_NICK; $icon = $DEF_ICON; if(@ARGV) { ($login, $password, $server, $port) = &Parse_Command_Line; } else { ($login, $password, $server, $port) = &Get_Login_Pass; } $hlc = new Net::Hotline::Client; $hlc->blocking(0); $hlc->event_timing(1.0); $hlc->default_handlers(0); &Set_Handlers($hlc); unless(&Connect($hlc, $server, $nick, $login, $password, $icon, $port)) { print $hlc->last_error(), "\n"; exit(1); } $BOT_NICK = $hlc->nick(); $hlc->run(); &Bye($hlc); } ## ## Setup functions ## # # Parse command line arguments # sub Parse_Command_Line { if(@ARGV > 1) { &Usage; } else { $_ = $ARGV[0]; s#^ho?t?li?n?e?://##i; s#/$##; if(m{^([^:]+):([^@]+)@([^:/]*) # Login, pass, server (?::(\d+))?$ # Port }ix) { return($1, $2, $3, $4); } elsif(m{^([^:@]+):?@([^:/]*) # Login, server (?::(\d+))?$ # Port }ix) { return($1, $DEF_PASSWORD, $2, $3); } elsif(m{^([^:/]*)(?::(\d+))?$}i) # Server, port { return($DEF_LOGIN, $DEF_PASSWORD, $1, $2); } else { &Usage; } } } # # Get server, login, password, etc. # sub Get_Login_Pass { my($login, $password, $server, $port); print "Server: "; chomp($server = ); $server =~ s/^\s*(.*?)\s*$/$1/; if($server =~ /^(\S+?)(?:\s+|:)(\d+)$/) { $server = $1; $port = $2; } print "Login ($DEF_LOGIN): "; chomp($login = ); system 'stty', '-echo' unless($MACOS); print 'Password: '; chomp($password = ); unless($MACOS) { system 'stty', 'echo'; print "\n"; } $login = $DEF_LOGIN unless(length($login)); return($login, $password, $server, $port); } # # Set event and task handlers # sub Set_Handlers { my($hlc) = shift; # Events $hlc->chat_handler(\&Chat_Handler); $hlc->msg_handler(\&Msg_Handler); $hlc->join_handler(\&Join_Handler); $hlc->event_loop_handler(\&Event_Handler); } # # Connect to the server # sub Connect { my($hlc, $server, $nick, $login, $password, $icon, $port) = @_; &Debug("CONNECTING:\n\n", "SERVER: $server\n", " NICK: $nick\n", " LOGIN: $login\n", " PASS: $password\n", " ICON: $icon\n\n"); $server .= ":$port" if($port =~ /^\d+$/); $hlc->blocking_tasks(1); unless($hlc->connect($server)) { print $hlc->last_error(), "\n"; exit(1); } unless($hlc->login(Login => $login, Password => $password, Nickname => $nick, Icon => $icon)) { $hlc->disconnect if($hlc->connected); print $hlc->last_error(), "\n"; &Bye($hlc); } $hlc->blocking_tasks(0); return(1); } ## ## Event Handlers: ## # # Event loop # sub Event_Handler { my($hlc, $idle) = @_; # Time to go to sleep? if(!$SLEEPING && time() >= ($hlc->last_activity() + $SLEEP_IDLE_SECS)) { &Debug("idle = $idle Going to sleep: ", time(), "\n"); $ICON_SAVE = $hlc->icon() unless($ICON_SAVE); $hlc->icon($ICON_SLEEP); $SLEEPING = 1; $ABSORB_EVENTS = 1; } # Time to wake up from sleeping? elsif($SLEEPING && $ABSORB_EVENTS < 0 && time() <= ($hlc->last_activity() + $SLEEP_IDLE_SECS)) { &Debug("idle = $idle Waking up: ", time(), "\n"); $hlc->icon($ICON_SAVE); $ICON_SAVE = undef; $SLEEPING = 0; } # Absorb non-idle events elsif($ABSORB_EVENTS >= 0 && !$idle) { &Debug("Absorbing event: $ABSORB_EVENTS -> ", $ABSORB_EVENTS - 1, "\n"); $ABSORB_EVENTS--; } } # # Message handler - a new private message has arrived # sub Msg_Handler { my($hlc, $user, $msg_ref) = @_; &Do_Command($hlc, $user->socket(), $msg_ref, $user->nick()); } # # Join handler - a new user has joined # sub Join_Handler { my($hlc, $user) = @_; my($nick) = $user->nick(); my($socket) = $user->socket(); &Send_Greeting($hlc, $nick); } # # Chat handler - a new line of chat has appeared # sub Chat_Handler { my($hlc, $msg_ref) = @_; my($nick, $message); my($safe_nick) = quotemeta($BOT_NICK); if($$msg_ref !~ /^\s*$safe_nick: /) { if($$msg_ref =~ /^(.{13}):\s*\/(?:$safe_nick|$PROPER_BOT_NICK|$BOT_NICK_ABBREV)\s*(\S.*)/i) { $nick = $1; $message = $2; $nick =~ s/^\s*(.*?)\s*$/$1/; &Do_Command($hlc, 'CHAT', \$message, $nick); } } } ## ## Actions ## # # Do command in response to chat or msg # sub Do_Command { my($hlc, $socket, $msg_ref, $nick) = @_; $$msg_ref =~ s/^\s*(.*?)\s*$/$1/; $_ = $$msg_ref; if(/^nick(?:name)?\s+(.*)/i) { &Change_Nick($hlc, $1, $nick); } elsif(/^icon\s+(\S.*)$/i) { my($icon) = $1; if($icon =~ /^-?\d+$/) { &Set_Icon($hlc, $icon) } } elsif(/^say\s+(\S.*)/i) { $hlc->chat($1); } elsif(/^(?:action|do)\s+(\S.*)/i) { $hlc->chat_action($1); } elsif(/^bye$/o) { $hlc->disconnect(); exit(0); } elsif(/^(help\??|\?+)$/i) { &My_Msg($hlc, $socket, &Help); } elsif(/^8(?:-|\s*)ball\s+(\S.*)$/i) { my($msg) = $EIGHTBALL[int(rand(@EIGHTBALL))]; &My_Msg($hlc, $socket, $msg) if($msg); } else { &My_Msg($hlc, $socket, "Invalid command."); } } # # List valid bot commands (short) # sub Help { my($ret)=<<"EOF"; Commands $BOT_NICK knows: say Say in chat. do Sat as a chat action. nick Change the bot's nickname to . icon Change the bot's icon to 8-ball The classic 8-ball fortune teller. bye Shut down the bot. EOF $ret; } # # Change bot nick # sub Change_Nick { my($hlc, $new_nick, $nick) = @_; if($new_nick =~ m/^"/ && $new_nick =~ m/(^|[^\\])"$/) { $new_nick =~ s/^"//; $new_nick =~ s/"$//; } for($new_nick) { s/\\"/"/g; s/(.{28}).*/$1/; } $hlc->nick("${new_nick}bot"); $BOT_NICK = $hlc->nick(); } # # Send greeting # sub Send_Greeting { my($hlc, $nick) = @_; my($greeting) = $GREETINGS[int(rand(@GREETINGS))]; $hlc->chat("$greeting $nick."); } # # Set bot icon # sub Set_Icon { my($hlc, $icon) = @_; $ICON_SAVE = $hlc->icon() if($ICON_SAVE); $hlc->icon($icon); } # # Chat/private message sender # sub My_Msg { my($hlc, $user_or_socket, @message) = @_; return unless($user_or_socket); if($user_or_socket eq 'CHAT') { $hlc->chat(@message); } else { $hlc->msg($user_or_socket, @message); } } # # Clean up and exit # sub Bye { my($hlc) = shift; $hlc->disconnect if(ref($hlc) && $hlc->connected); exit(0); } # # Debuging # sub Debug { print @_ if($OPT{'D'}); } # # Usage message # sub Usage { print STDERR "Usage: hibot [hotline://user:pass\@host.com:port/]\n", "-D A touch of debugging output.\n", "-h Show this help screen.\n"; exit(1); } "Very doubtful.", "It is certain.", "Ask again later.", "Yes.", "Reply hazy, try again.", "Cannot predict now.", "Don't count on it."); ## ## Main function ## MAIN: { my($nick, $login, $password, $server, $icon, $port); $nick = $DEF_NICK; $icon = $DEF_ICON; if(@ARGV) { ($login, $password, $server, $port) = &Parse_Command_Line;Net-Hotline-0.83/Examples/README010064400427010022003000000017260757122345200174260ustar00macintshalumni00000400000004The two scripts in this directory are meant to demonstrate the two modes of operation present in Net::Hotline::Client. They haven't been very well tested, so don't expect stellar reliability. 1. "hlftp.pl" is a simple command line FTP-like Hotline client included to demonstrate Net::Hotline::Client's "blocking task mode" (read the documentation for an explanation). Its operation should be familiar to anyone who's used ncftp or the regular Unix ftp client. The version of "hlftp.pl" included here may be out of date by the time you read this. Please check the following URL for the latest version: http://siracusa.home.mindspring.com/Perl/ 2. "hibot.pl" is a very simple Hotline "bot" included to demonstrate Net::Hotline::Client's "event loop mode" (again, RTFM). It works a lot like hlftp.pl in terms of connecting to servers. Log the bot onto your local Hotline server an message it with the text "help" for more information. Net-Hotline-0.83/Examples/hlftp.pl010064400427010022003000001131410757122345100202120ustar00macintshalumni00000400000004#!/usr/local/bin/perl ## Copyright(c) 1998-1999 by John C. Siracusa. All rights reserved. This ## program is free software; you can redistribute it and/or modify it under ## the same terms as Perl itself. ## ## hlftp.pl - A simple FTP-like hotline client by John Siracusa, created to ## demonstrate the Net::Hotline::Client module's blocking task mode. ## ## Created: July 10th, 1998 ## Modified: September 21st, 1999 ## use strict; use Cwd; use Text::Wrap; use Getopt::Std; use Term::ReadLine; use Time::localtime; use Net::Hotline::Client; use Net::Hotline::Constants qw(HTXF_PARTIAL_TYPE HTXF_PARTIAL_CREATOR HTLC_MACOS_TO_UNIX_TIME HTLC_FOLDER_TYPE HTLC_INFO_FOLDER_TYPE HTLC_INFO_FALIAS_TYPE); my $VERSION = '1.07'; my(%OPT, $LPWD, $RPWD, $NICK, $TERM); getopts('bchn:pquvx', \%OPT); if($OPT{'v'}) { print "hlftp version $VERSION by John Siracusa\n"; exit(0); } Usage() if($OPT{'h'}); my $DEF_LOGIN = 'guest'; my $DEF_PASSWORD = ''; my $DEF_SERVER = undef; my $DEF_PORT = undef; my $DEF_ICON = 410; my $ICON = $DEF_ICON; my $LOGIN = $DEF_LOGIN; my $MACOS = ($^O eq 'MacOS'); my $LOCAL_SEP = ($MACOS) ? ':' : '/'; my $REMOTE_SEP = ':'; my $MACBIN_MODE = ($OPT{'b'} || !$MACOS) ? 1 : 0; my $CLOBBER_MODE = ($OPT{'c'}) ? 1 : 0; my $PROMPTING = 1; my $COLS = $ENV{'COLUMNS'} || $ENV{'COLS'} || 80; $Text::Wrap::columns = $COLS; my $OUT = *STDOUT; $Net::Hotline::Client::DEBUG = 0; my $FOLDER_REGEX = join ('|', HTLC_FOLDER_TYPE, HTLC_INFO_FOLDER_TYPE, HTLC_INFO_FALIAS_TYPE); my %HELP = ( 'cd' => 'cd Change remote working directory to ', 'clobber' => 'clobber Toggle overwrite-when-downloading behavior.', 'close' => 'close Disconnect from the server.', 'del' => 'del Delete from the server.', 'dir' => 'dir Does an "ls -l" on in the server.', 'get' => 'get Get from the remote server.', 'help' => 'help Get general help or help for ', 'icon' => 'icon Set your icon to ', 'info' => 'info Get information about ', 'lcd' => 'lcd Change local working directory to ', 'ldir' => 'ldir Does an "ls -l" on the local directory ', 'lls' => 'lls [-l] List files in the local directory ', 'lpwd' => 'lpwd Show the current local working directory.', 'ls' => 'ls [-l] List files in on the server.', 'macbin' => 'macbin Toggle MacBinary download mode.', 'mget' => 'mget Get files matching from the server.', 'mput' => 'mput Put files matching on server.', 'nick' => 'nick Set your nickname to ', 'open' => 'open Open connection to ', 'prompt' => 'prompt Toggle cautionary prompting.', 'pwd' => 'pwd Show the current remote working directory.', 'quiet' => 'quiet Quiet mode: less verbose output.', 'quit' => 'quit Exit hlftp.', 'status' => 'status Show current status.', 'version' => 'version Show the hlftp version number.', 'wd' => 'wd Show local and remote working directories.'); sub print_wrap; # Forward declaration MAIN: { my($login, $pass, $server, $port, $path) = Parse_Command_Line(); my($hlc) = Start_Up($login, $pass, $server, $port, $path); Converse($hlc, $server); } sub Parse_Command_Line { if(@ARGV == 0) { return($DEF_LOGIN, $DEF_PASSWORD, $DEF_SERVER, $DEF_PORT, undef); } elsif(@ARGV > 1) { Usage(); } else { $_ = $ARGV[0]; s#^ho?t?li?n?e?://##i; if(m{^([^:]+):([^@]+)@([^:/]*) # Login, pass, server (?::(\d+))? # Port (/.*)?$ # Path }ix) { return($1, $2, $3, $4, $5); } elsif(m{^([^:@]+):?@([^:/]*) # Login, server (?::(\d+))? # Port (/.*)?$ # Path }ix) { return($1, $DEF_PASSWORD, $2, $3, $4); } elsif(m{^([^:/]*)(?::(\d+))? # Server, port (/.*)?$ # Path }ix) { return($DEF_LOGIN, $DEF_PASSWORD, $1, $2, $3); } else { Usage(); } } } sub Usage { print STDERR<<'EOF'; Usage: hlftp [-bchpquvx] [-n nick] [hotline://user:pass@host.com:port/path/] -b MacBinary mode (on by default on non-Mac OS systems). -c Clobber mode: overwrite existing files. -h Show this help screen. -p Use shorter prompt. -q Quiet mode: less verbose output. -u Prompt for username and password. -v Show the hlftp version number. -x Exit after failed command line connections. EOF exit(1); } sub Help { my($cmd) = shift; my($printed); if($cmd =~ /\S/) { $cmd = Shell_RE_To_Perl_RE($cmd); if(Safe_Regex(\$cmd)) { foreach my $hcmd (sort(keys(%HELP))) { if($hcmd =~ /^$cmd$/i) { print $OUT "\n" unless($printed); print_wrap $HELP{$hcmd}, "\n"; $printed = 1; } } if($printed) { print $OUT "\n" } else { print_wrap "No commands matching \"$cmd\" were found.\n"; } } else { print_wrap "Bad regex: $cmd\n"; } } else { my(@cmds, $i, $j, $cols); @cmds = sort(keys(%HELP)); $cols = int($COLS/10); print_wrap "'help ' gives a brief description of \n\n"; for($i = 0; $i <= $#cmds;) { for($j = 0; $j < $cols && $i <= $#cmds; $j++) { print $OUT sprintf("%-10s", $cmds[$i]); $i++; } print $OUT "\n"; } print $OUT "\n"; } } sub Start_Up { my($login, $pass, $server, $port, $path) = @_; my($server_arg) = $server; if($MACBIN_MODE && $MACOS) { print_wrap "Sorry, MacBinary mode is disabled on Mac OS.\n"; MacBinary_Mode('off'); } ($login, $pass) = Login_Pass() if($OPT{'u'}); my($hlc) = new Net::Hotline::Client; $LPWD = cwd(); $hlc->downloads_dir($LPWD); $hlc->blocking_tasks(1); return($hlc) unless($server); $path = Convert_Path($path); $server_arg .= ":$port" if($port =~ /^\d+$/); print_wrap "Connecting to $server_arg...\n" unless($OPT{'q'}); unless($hlc->connect($server_arg)) { print_wrap $hlc->last_error(), "\n"; exit(1) if($OPT{'x'}); return($hlc); } unless(length($NICK)) { if($OPT{'n'}) { $NICK = $OPT{'n'} } else { $NICK = $login } } print_wrap "Logging in as \"$login\"...\n" unless($OPT{'q'}); unless($hlc->login(Login => $login, Password => $pass, Nickname => $NICK, Icon => $DEF_ICON, News => 'no', UserList => 'no')) { print_wrap "Login to $server_arg failed: ", $hlc->last_error(), "\n"; exit(1) if($OPT{'x'}); return($hlc); } $LOGIN = $login; unless(length($NICK)) { if($OPT{'n'}) { $NICK = $OPT{'n'} } else { $NICK = $login } } if($path =~ m#:|/#) { print_wrap "Changing directory to ...\n" unless($OPT{'q'}); Change_Dir_Remote($hlc, $path); } elsif(length($path)) { # Check that path is a directory my($info) = $hlc->get_fileinfo($path); unless($info) { print_wrap "No such file or directory: $path\n"; if($OPT{'x'}) { $hlc->disconnect(); exit(1); } return($hlc); } if($info->type() =~ /^($FOLDER_REGEX)$/i) { print_wrap "Changing directory to $path...\n" unless($OPT{'q'}); Change_Dir_Remote($hlc, $path); } else { if(Get_File($hlc, $path)) { $hlc->disconnect(); exit; } } } else { $RPWD = ''; } return($hlc); } sub Disconnect { my($hlc, $prompt_ref) = @_; if($hlc->connected()) { $hlc->disconnect(); print_wrap "Connection closed.\n" unless($OPT{'q'}); Set_Prompt($hlc, $prompt_ref); } else { print_wrap "Not connected.\n" unless($OPT{'q'}); } } sub Reconnect { my($hlc, $user_pass, $server) = @_; my($login, $pass); if($hlc->connected()) { print_wrap "Closing connection to ", $hlc->server(), "...\n"; $hlc->disconnect(); } if($user_pass) { ($login, $pass) = Login_Pass(); } else { ($login, $pass) = ($DEF_LOGIN, $DEF_PASSWORD); } unless(length($NICK)) { if($OPT{'n'}) { $NICK = $OPT{'n'} } else { $NICK = $login } } $LOGIN = $login; $RPWD = ''; print_wrap "Connecting to $server...\n" unless($OPT{'q'}); unless($hlc->connect($server)) { print_wrap "Connection failed.\n"; return; } print_wrap "Logging in as \"$login\"...\n" unless($OPT{'q'}); unless($hlc->login(Login => $login, Password => $pass, Nickname => $NICK, Icon => $ICON, NoNews => 1, NoUserList => 1)) { print_wrap "Login to $server failed: ", $hlc->last_error(), "\n"; return; } return(1); } sub Login_Pass { my($login, $pass, $def); if($NICK) { $def = $NICK } elsif($OPT{'n'}) { $def = $OPT{'n'} } else { $def = $DEF_LOGIN } print_wrap "Login ($def): "; chomp($login = ); system 'stty', '-echo' unless($MACOS); print_wrap 'Password: '; chomp($pass = ); unless($MACOS) { system 'stty', 'echo'; print $OUT "\n"; } $login = $def unless(length($login)); $pass = $DEF_PASSWORD unless(length($pass)); return($login, $pass); } sub Converse { my($hlc, $server) = @_; my($cmd, $prompt); $TERM = new Term::ReadLine 'Hotline FTP'; $OUT = $TERM->OUT || *STDOUT; print $OUT "Welcome to hlftp version $VERSION by John Siracusa\n" unless($OPT{'q'} || @ARGV); Set_Prompt($hlc, \$prompt); while(defined($cmd = $TERM->readline($prompt))) { Process_Command($hlc, $cmd, \$prompt); $TERM->addhistory($cmd) if($cmd =~ /\S/); } } sub Process_Command { my($hlc, $cmd, $prompt_ref) = @_; return unless($cmd =~ /\S/); for($cmd) { s/^\s*//; s/\s*$//; } return unless(length($cmd)); $_ = $cmd; if(/^ls(?:\s+(?:(-l)(?:\s+|$))?(.*))?/) { List($hlc, $1, $2); } elsif(/^lls(?:\s+(?:(-l)(?:\s+|$))?(.*))?/) { List_Local($hlc, $1, $2); } elsif(/^(?:dir|ll)(?:\s+(\S.*))?$/) { List($hlc, '-l', $1); } elsif(/^(?:lll|ldir)(?:\s+(\S.*))?$/) { List_Local($hlc, '-l', $1); } elsif(/^cd\s+(\S.*)/) { Change_Dir_Remote($hlc, $1); } elsif(/^\.\.$/) { Change_Dir_Remote($hlc, '..'); } elsif(/^lcd\s+(\S.*)/) { Change_Dir_Local($hlc, $1); } elsif(/^get\s+(\S.*)/) { Get_File($hlc, $1); } elsif(/^mget\s+(\S.*)/) { Get_Files($hlc, $1); } elsif(/^put\s+(\S.*)/) { Put_File($hlc, $1); } elsif(/^mput\s+(\S.*)/) { Put_Files($hlc, $1); } elsif(/^(?:del(?:ete)?|rm)\s+(\S.*)/) { Delete_File($hlc, $1); } elsif(/^mkdir\s+(\S.*)/) { Make_Dir($hlc, $1); } elsif(/^clobber(?:\s+(on|yes|off|no))?$/) { Clobber_Mode($hlc, $1); } elsif(/^(?:mac)?bin(?:ary)?(?:\s+(on|yes|off|no))?$/) { MacBinary_Mode($1); } elsif(/^info(?:rmation)?\s+(\S.*)/) { Get_Info($hlc, $1); } elsif(/^(?:\?+|help)(?:\s+(\S.*))?$/i) { Help($1); } elsif(/^close$/) { Disconnect($hlc, $prompt_ref); } elsif(/^open\s+(?:(-u)\s+)?(\S.*)/) { Reconnect($hlc, $1, $2); Set_Prompt($hlc, $prompt_ref); } elsif(/^prompt$/) { $PROMPTING = ($PROMPTING) ? 0 : 1; print $OUT "Interactive mode ", ($PROMPTING) ? 'on' : 'off', ".\n"; } elsif(/^long\s*prompt$/) { $OPT{'p'} = 0; Set_Prompt($hlc, $prompt_ref); } elsif(/^short\s*prompt$/) { $OPT{'p'} = 1; Set_Prompt($hlc, $prompt_ref); } elsif(/^ver(s(ion)?)?$/) { print $OUT "hlftp version $VERSION by John Siracusa\n"; } elsif(/^[cp]wd$/) { print_wrap "Remote dir: ", (length($RPWD)) ? $RPWD : '', "\n"; } elsif(/^l[cp]?wd$/) { print_wrap "Local dir: $LPWD\n"; } elsif(/^wd$/) { print_wrap "Local dir: $LPWD\n", "Remote dir: ", (length($RPWD)) ? $RPWD : '', "\n"; } elsif(/^(?:q(?:uit)?|bye|exit|x)$/) { $hlc->disconnect(); exit; } elsif(/^nick\s+("?)(\S.*?)\1$/) #" { if(Nick($hlc, $2)) { Set_Prompt($hlc, $prompt_ref); } } elsif(/^icon\s+(\d+)/) { Icon($hlc, $1); Set_Prompt($hlc, $prompt_ref); } elsif(/^stat(s|us)?/) { Status($hlc); } elsif(/^quiet|shh+$/) { $OPT{'q'} = !$OPT{'q'}; print_wrap "Quiet mode OFF.\n" unless($OPT{'q'}); } else { print_wrap "Invalid command: $cmd\n"; } } sub Status { my($hlc) = shift; if($hlc->connected()) { print_wrap "Nick: $NICK\n", "Login: $LOGIN\n", "Icon: $ICON\n", "Server: ", $hlc->server(), "\n", "Local: $LPWD\n", "Remote: ", (length($RPWD)) ? $RPWD : '', "\n", } else { print_wrap "Nick: $NICK\n", "Login: $LOGIN\n", "Icon: $ICON\n", "Server: (Not connected)\n", "Local: $LPWD\n", "Remote: (Not connected)\n"; } } sub MacBinary_Mode { my($onoff) = shift; if($MACOS) { print_wrap "Sorry, MacBinary mode is disabled on Mac OS.\n"; return; } if(defined($onoff)) { if($onoff =~ /^(on|yes)$/i) { $MACBIN_MODE = 1; print_wrap "MacBinary mode ON.\n"; } else { $MACBIN_MODE = 0; print_wrap "MacBinary mode OFF.\n"; } } else { $MACBIN_MODE = !$MACBIN_MODE; print_wrap "MacBinary mode ", ($MACBIN_MODE) ? 'ON' : 'OFF', "\n"; } } sub Clobber_Mode { my($hlc, $onoff) = @_; if(defined($onoff)) { if($onoff =~ /^(on|yes)$/i) { $CLOBBER_MODE = 1; print_wrap "Clobber mode ON.\n"; } else { $CLOBBER_MODE = 0; print_wrap "Clobber mode OFF.\n"; } } else { $CLOBBER_MODE = !$CLOBBER_MODE; print_wrap "Clobber mode ", ($CLOBBER_MODE) ? 'ON' : 'OFF', "\n"; } } sub Get_File { my($hlc, $path, $absolute) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } my($file, $task, $ref, $size, $data_file, $rsrc_file, $finished_file, $resume, $ret, $clobber, @path); if($absolute) { @path = split($REMOTE_SEP, $path); } else { @path = Rel_To_Abs_Path_Remote(Convert_Path(Clean_Path($path))) } $path = join($REMOTE_SEP, @path); $file = $path[$#path]; if(length($path)) { # Check that path exists and is a file my($info) = $hlc->get_fileinfo($path); unless($info && $info->type() !~ /^($FOLDER_REGEX)$/) { print_wrap "No such file: $path\n"; return; } } else { print_wrap "No such file: $path\n"; return; } $finished_file = Rel_To_Abs_Path_Local($file); $data_file = $finished_file . $hlc->data_fork_extension(); $rsrc_file = $finished_file . $hlc->rsrc_fork_extension(); if(-e $finished_file) { $clobber = 1; if($MACOS) { my($creator, $type) = MacPerl::GetFileInfo($finished_file); if($type eq Net::Hotline::Constants::HTXF_PARTIAL_TYPE && $creator eq Net::Hotline::Constants::HTXF_PARTIAL_CREATOR) { $resume = 1; $clobber = 0; } } } if($clobber) { if($CLOBBER_MODE) { unless(unlink($finished_file)) { print_wrap "Could not delete $file: $!\n"; return; } } else { print_wrap "\"$file\" already exists. Set \"clobber\" to overwrite.\n"; return; } } if(!$MACOS) { $resume = (-e $rsrc_file || -e $data_file); } if(-e "$finished_file.bin" && $MACBIN_MODE) { if($CLOBBER_MODE) { unless(unlink("$finished_file.bin")) { print_wrap "Could not delete $file.bin: $!\n"; return; } } else { print_wrap "\"$file.bin\" already exists. Set \"clobber\" to overwrite.\n"; return; } } if($resume) { ($task, $ref, $size) = $hlc->get_file_resume($path); } else { ($task, $ref, $size) = $hlc->get_file($path); } unless($task) { print_wrap $hlc->last_error(), "\n"; return; } if($resume) { print_wrap "Resuming file download: \"$file\" ($size bytes)...\n" unless($OPT{'q'}); } else { print_wrap "Getting file \"$file\" ($size bytes)...\n" unless($OPT{'q'}); } $ret = $hlc->recv_file($task, $ref, $size); unless($ret) { print_wrap "Download failed: ", $hlc->last_error(), "\n"; return; } if($MACBIN_MODE && ref($ret)) { print_wrap "Creating MacBinary file \"$file.bin\"...\n" unless($OPT{'q'}); unless($hlc->macbinary(undef, $ret)) { print_wrap "Could not create MacBinary file: ", $hlc->last_error(), "\n"; return; } # Delete the separate data and resource fork files unlink($data_file) if(-e $data_file); unlink($rsrc_file) if(-e $rsrc_file); } return(1); } sub Put_File { my($hlc, $path) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } my($file, $task, $ref, $size, $remote_path, $check_file, $files, $resume, $replace, $rflt, @path); @path = Rel_To_Abs_Path_Local($path); $file = $path[$#path]; $remote_path = "$RPWD:$file"; unless(-e $path) { print_wrap "File not found: $path\n"; return; } if(-d $path) { print_wrap "Cannot put a directory. Use \"mput\" instead.\n"; return; } $files = $hlc->get_filelist($RPWD); unless($files) { print_wrap "Could not get file list for folder $RPWD: ", $hlc->last_error(), "\n"; return; } foreach my $check_file (@{$files}) { next unless($check_file->name() eq $file); if($check_file->type() eq HTXF_PARTIAL_TYPE && $check_file->creator() eq HTXF_PARTIAL_CREATOR) { $resume = 1; } else { $replace = 1; } } if($replace) { print_wrap "A file named \"$file\" already exists.\n"; return; } if($resume) { ($task, $ref, $size, $rflt) = $hlc->put_file_resume($path, $RPWD); } else { ($task, $ref, $size) = $hlc->put_file($path, $RPWD); } unless($task) { print_wrap $hlc->last_error(), "\n"; return; } if($resume) { print_wrap "Resuming upload of file \"$file\" ($size bytes)...\n" unless($OPT{'q'}); } else { print_wrap "Putting file \"$file\" ($size bytes)...\n" unless($OPT{'q'}); } unless($hlc->send_file($task, $ref, $size, $rflt)) { print_wrap "Upload failed: ", $hlc->last_error(), "\n"; return; } return(1); } sub Put_Files { my($hlc, $path) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } my(@path, $save_path, $dir, $check_path, $file, $regex, $found, $cd_backone, $res); $save_path = $path; @path = Rel_To_Abs_Path_Local($path); $check_path = Rel_To_Abs_Path_Local($path); if(-d $check_path) { print_wrap "Put the entire directory \"$save_path\"? (y/n) [n]: "; chomp($res = ); unless($res =~ /^\s*y(es|up|eah)?\s*$/i) { print_wrap "mput aborted.\n"; return(0); } $dir = $check_path; $regex = '*'; unless(Make_Dir($hlc, $path[$#path])) { print_wrap "mput aborted.\n"; return(0); } unless(Change_Dir_Remote($hlc, $path[$#path])) { print_wrap "mput aborted.\n"; return(0); } $cd_backone = 1; } else { $dir = (($MACOS) ? '' : $LOCAL_SEP) . join($LOCAL_SEP, @path[0 .. $#path - 1]); $regex = $path[$#path]; } $regex = Shell_RE_To_Perl_RE($regex); unless(Safe_Regex(\$regex)) { $regex = quotemeta($regex); } unless(opendir(DIR, $dir)) { print_wrap "Could not read directory \"$dir\" - $!\n"; return(0); } while($file = readdir(DIR)) { next if($file !~ /^$regex$/); if(-d "$dir$LOCAL_SEP$file") { print_wrap "Skipping directory \"$dir$LOCAL_SEP$file\"\n" unless($OPT{'q'} || ($file =~ /^\.\.?$/ && !$MACOS)); next; } $found = 1; if($PROMPTING) { print_wrap "Put \"$file\"? (ynq) [n]: "; chomp($res = ); if($res =~ /^\s*q(uit)?\s*$/i) { print_wrap "mput aborted.\n"; return(0); } elsif($res !~ /^\s*y(es|up|eah)?\s*/i) { next; } } unless(Put_File($hlc, "$dir$LOCAL_SEP$file")) { if($PROMPTING) { my($res); print_wrap "Continue with mput? (y/n) [n]: "; chomp($res = ); return(1) unless($res =~ /^\s*y(es|up|eah)?\s*/i); } } } if($cd_backone) { Change_Dir_Remote($hlc, '..'); } unless($found) { print $OUT "mput: No match.\n"; } return(1); } sub Get_Files { my($hlc, $path) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } my(@path, $files, $name, $info, $regex, $save_path, $res, $file_path, $file_dir); $save_path = $path; @path = Rel_To_Abs_Path_Remote(Convert_Path(Clean_Path($path))); $path = join($REMOTE_SEP, @path); if(length($path)) { $info = $hlc->get_fileinfo($path); # Last part of the path could have been a regex unless(ref($info)) { $regex = pop(@path); $path = join($REMOTE_SEP, @path); if(length($path)) { $info = $hlc->get_fileinfo($path); unless(ref($info) && $info->type() =~ /^($FOLDER_REGEX)$/i) { print_wrap "No such file or directory: $save_path\n"; return; } } } elsif($info->type() =~ /^($FOLDER_REGEX)$/i) { print_wrap "Get the entire contents of the folder \"$path\"? (y/n) [n]: "; chomp($res = ); unless($res =~ /^\s*y(es|up|eah)?\s*$/i) { print_wrap "mget aborted.\n"; return(0); } } } if(defined($regex)) { $regex = Shell_RE_To_Perl_RE($regex); unless(Safe_Regex(\$regex)) { $regex = quotemeta($regex); } } $files = $hlc->get_filelist($path); $file_dir = $path; $path = '' unless(length($path)); unless($files) { print_wrap "Could not get file list for folder $path: ", $hlc->last_error(), "\n"; return; } foreach my $file (@{$files}) { $name = $file->name(); next if(defined($regex) && $name !~ /^$regex$/); if($PROMPTING) { print_wrap "Get \"$name\"? (ynq) [n]: "; chomp($res = ); if($res =~ /^\s*q(uit)?\s*$/i) { print_wrap "mget aborted.\n"; return(0); } elsif($res !~ /^\s*y(es|up|eah)?\s*/i) { next; } } $file_path = Rel_To_Abs_Path_Remote($name, $file_dir); unless(Get_File($hlc, $file_path, 'absolute')) { if($PROMPTING) { my($res); print_wrap "Continue with mget? (y/n) [n]: "; chomp($res = ); return(1) unless($res =~ /^\s*y(es|up|eah)?\s*/i); } } } return(1); } sub Nick { my($hlc, $nick) = @_; $nick =~ s/(^|^[^\\]|[^\\]{2})"/$1"/g; $nick =~ s/^(.{,31}).*/$1/; if(length($nick)) { $hlc->nick($nick) if($hlc->connected()); $NICK = $nick; return(1); } return; } sub Icon { my($hlc, $icon) = @_; $hlc->icon($icon) if($hlc->connected()); $ICON = $icon; } sub Get_Info { my($hlc, $path) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } my($name, @path, $info); @path = Rel_To_Abs_Path_Remote(Convert_Path(Clean_Path($path))); $path = join($REMOTE_SEP, @path); $name = $path[$#path]; $info = $hlc->get_fileinfo($path); unless(ref($info)) { print_wrap($hlc->last_error(), "\n"); return; } my($size, $units, $comments); ($size, $units) = Size_Units($info->size()); print_wrap "\n", "Name: ", $info->name(), "\n", "Size: $size $units\n", "Type: ", $info->type(), "\n", "Creator: ", $info->creator(), "\n", "Created: ", Date_Text($info->ctime()), "\n", "Modified: ", Date_Text($info->mtime()), "\n"; $comments = $info->comment(); if(length($comments)) { print_wrap "Comments: $comments\n"; } print $OUT "\n"; return(1); } sub Make_Dir { my($hlc, $path) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } my($name, @path); @path = Rel_To_Abs_Path_Remote(Convert_Path(Clean_Path($path))); $path = join($REMOTE_SEP, @path); $name = $path[$#path]; unless($hlc->new_folder($path)) { print_wrap($hlc->last_error(), "\n"); return; } print_wrap "Folder created: $name\n" unless($OPT{'q'}); return(1); } sub Delete_File { my($hlc, $path) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } my($folder, $name, @path, $res, $info, $regex, $save_path, $file_path, $file_dir, $found, $files); @path = Rel_To_Abs_Path_Remote(Convert_Path(Clean_Path($path))); $path = join($REMOTE_SEP, @path); $name = $path[$#path]; $save_path = $path; $info = $hlc->get_fileinfo($path); # Last part of the path could have been a regex unless(ref($info)) { $regex = pop(@path); $path = join($REMOTE_SEP, @path); if(length($path)) { $info = $hlc->get_fileinfo($path); unless(ref($info) && $info->type() =~ /^($FOLDER_REGEX)$/i) { print_wrap "No such file or directory: $save_path\n"; return; } } } else { if($info->type() =~ /^($FOLDER_REGEX)$/i && $PROMPTING) { $folder = 1; print_wrap "Really delete the folder \"$name\" and all its contents? (y/n) [n]: "; chomp($res = ); return(0) unless($res =~ /^\s*y(es|up|eah)?\s*$/i); } unless($hlc->delete_file($path)) { print_wrap $hlc->last_error(), "\n"; return; } print_wrap +($folder) ? "Folder" : "File", " deleted: $name\n" unless($OPT{'q'}); return(1); } if(defined($regex)) { $regex = Shell_RE_To_Perl_RE($regex); unless(Safe_Regex(\$regex)) { $regex = quotemeta($regex); } } $files = $hlc->get_filelist($path); $file_dir = $path; $path = '' unless(length($path)); unless($files) { print_wrap $hlc->last_error(), "\n"; return; } foreach my $file (@{$files}) { $name = $file->name(); next if(defined($regex) && $name !~ /^$regex$/); $found = 1; $folder = ($file->type() eq HTLC_FOLDER_TYPE); if($PROMPTING) { if($folder) { print_wrap "Really delete the folder \"$name\" and all its contents? (ynq) [n]: "; } else { print_wrap "Really delete \"$name\"? (ynq) [n]: "; } chomp($res = ); if($res =~ /^\s*q(uit)?\s*/i) { return(0); } elsif($res !~ /^\s*y(es|up|eah)?\s*$/i) { next; } } $file_path = Rel_To_Abs_Path_Remote($name, $file_dir); unless($hlc->delete_file($file_path)) { print_wrap $hlc->last_error(), "\n"; next; } print_wrap +($folder) ? "Folder" : "File", " deleted: $name\n" unless($OPT{'q'}); } if(!$found && !$OPT{'q'}) { print_wrap "del: No match.\n"; } return(1); } sub Rel_To_Abs_Path_Local { my($path, $start_dir) = @_; unless(length($path)) { return (split(/$LOCAL_SEP/, $LPWD)) if(wantarray); return $LPWD; } my($tmp, $dir, @dirs, @path, $ret); $start_dir = $LPWD unless(defined($start_dir)); if($path !~ /^$LOCAL_SEP/) { $tmp = "$start_dir$LOCAL_SEP$path"; } else { $tmp = $path; } $tmp =~ s/$LOCAL_SEP+/$LOCAL_SEP/g; @dirs = split(/$LOCAL_SEP/, $tmp); foreach my $dir (@dirs) { if($dir eq '..') { pop(@path) } elsif($dir eq '.') { next } elsif(length($dir)) { push(@path, $dir) } } # MacPerl's chdir() likes a trailing ':' if($MACOS) { $ret = join($LOCAL_SEP, @path) . $LOCAL_SEP; } # Other OSes have leading path separators on their absolute paths else { $ret = $LOCAL_SEP . join($LOCAL_SEP, @path); } return @path if(wantarray); return $ret; } sub Rel_To_Abs_Path_Remote { my($path, $start_dir) = @_; my($tmp, $dir, @dirs, @path); $start_dir = $RPWD unless(defined($start_dir)); if($path !~ /^$REMOTE_SEP/) { $tmp = "$start_dir$REMOTE_SEP$path"; } else { ($tmp = $path) =~ s/^$REMOTE_SEP//o; } $tmp =~ s/$REMOTE_SEP+/$REMOTE_SEP/g; @dirs = split(/$REMOTE_SEP/, $tmp); foreach my $dir (@dirs) { if($dir eq '..') { pop(@path) } elsif($dir eq '.') { next } elsif(length($dir)) { push(@path, $dir) } } return @path if(wantarray); return join($REMOTE_SEP, @path); } sub Change_Dir_Local { my($hlc, $path) = @_; $path = Rel_To_Abs_Path_Local($path); unless(chdir($path)) { print_wrap "Could not change directory to $path: $!\n"; return; } $LPWD = cwd(); $hlc->downloads_dir($LPWD); print_wrap "lcwd: $LPWD\n" unless($OPT{'q'}); } sub Change_Dir_Remote { my($hlc, $path) = @_; unless($hlc->connected()) { print_wrap "Not connected.\n"; return; } if($path =~ m#^(?:|/)$#) { $RPWD = ''; } else { my($abs) = ($path =~ m{^[:/]}); $path = Convert_Path(Clean_Path($path)); $path = Rel_To_Abs_Path_Remote($path) unless($abs); if(length($path)) { # Check that path exists and is a folder my($info) = $hlc->get_fileinfo($path); unless($info && $info->type() =~ /^(?:$FOLDER_REGEX)$/) { print_wrap "No such directory: $path\n"; return; } } $RPWD = $path; } unless($OPT{'q'} || $OPT{'p'}) { print_wrap "cwd: ", (length($RPWD)) ? $RPWD : '', "\n"; } } sub List { my($hlc, $long, $path) = @_; unless($hlc->connected()) { print $OUT "Not connected.\n"; return; } my(@path, $files, $info, $regex, $save_path); $save_path = $path; @path = Rel_To_Abs_Path_Remote(Convert_Path(Clean_Path($path))); $path = join($REMOTE_SEP, @path); if(length($path)) { $info = $hlc->get_fileinfo($path); # Last part of the path could have been a regex unless(ref($info)) { $regex = pop(@path); $path = join($REMOTE_SEP, @path); if(length($path)) { $info = $hlc->get_fileinfo($path); unless(ref($info) && $info->type() =~ /^($FOLDER_REGEX)$/i) { print_wrap "No such file or directory: $save_path\n"; return; } } } elsif($info->type() !~ /^($FOLDER_REGEX)$/i) { $regex = pop(@path); $path = join($REMOTE_SEP, @path); } } if(defined($regex)) { $regex = Shell_RE_To_Perl_RE($regex); unless(Safe_Regex(\$regex)) { $regex = quotemeta($regex); } } $files = $hlc->get_filelist($path); $path = '' unless(length($path)); unless($files) { print_wrap "Could not get file list for folder $path: ", $hlc->last_error(), "\n"; return; } unless(@{$files} > 0) { print_wrap "\n"; return; } if($long) { my($msg, $name, $size, $bytes, $type, $creator, $units); foreach my $file (@{$files}) { $name = $file->name(); next if(defined($regex) && $name !~ /^$regex$/); $size = $file->size(); $type = $file->type(); $creator = $file->creator(); $bytes = $size; $name .= ':' if($type eq HTLC_FOLDER_TYPE); if($type eq 'fldr') { $units = 'Items'; print $OUT sprintf("%-32s %10d %-5s Folder", $name, $size, $units); } else { if($size < 1024) { $units = 'bytes'; } elsif($size > 1024 && $size < (1024 * 1024)) { $units = 'KB'; $size = (int($size/1024)); } elsif($size > (1024 * 1024)) { $units = 'MB'; $size = $size/(1024 * 1024); } elsif($size > (1024 * 1024 *1024)) { $units = 'GB'; $size = $size/(1024 * 1024 *1024); } print $OUT sprintf("%-32s %10d %5.1f %-5s %4s %4s", $name, $bytes, $size, $units, $type, $creator); } print $OUT "\n"; } } else { my($max_length, $col_width, $cols, $name, @names, $i, $j); $max_length = 0; foreach my $file (@{$files}) { $name = $file->name(); next if(defined($regex) && $name !~ /^$regex$/); $name .= ':' if($file->type() eq HTLC_FOLDER_TYPE); push(@names, $name); $max_length = length($name) if(length($name) > $max_length); } $col_width = $max_length + 3; $col_width = 10 if($col_width < 10); $cols = int($COLS/$col_width); for($i = 0; $i <= $#names; $i += $cols) { for($j = 0; $j < $cols && defined($names[$i + $j]); $j++) { print $OUT $names[$i + $j], ' ' x ($col_width - length($names[$i + $j])); } print $OUT "\n"; } } } sub List_Local { my($hlc, $long, $path) = @_; my(@path, $files, $info, $regex, $save_path, $abs_path, $printed, $save_file, $save_abs_path); $save_path = $path; @path = Rel_To_Abs_Path_Local($path); $path = join($LOCAL_SEP, @path); $path .= $LOCAL_SEP if($MACOS); if(length($path)) { unless(-e $path) { $regex = pop(@path); $path = join($LOCAL_SEP, @path); $path .= $LOCAL_SEP if($MACOS); if(length($path)) { unless(-d $path) { print_wrap "No such file or directory: $save_path\n"; return; } } } } if(defined($regex)) { $regex = Shell_RE_To_Perl_RE($regex); unless(Safe_Regex(\$regex)) { $regex = quotemeta($regex); } } unless(opendir(DIR, $path)) { print_wrap "Could not read directory $path: $!\n"; return; } if($long) { my($file, $size, $is_dir, $bytes, $units, $type, $creator); foreach my $file (sort(readdir(DIR))) { $save_file = $file; $file =~ s/\015//g if($MACOS); next if(defined($regex) && $file !~ /^$regex$/); ($abs_path = "$path$LOCAL_SEP$file") =~ s/$LOCAL_SEP+/$LOCAL_SEP/og; ($save_abs_path = "$path$LOCAL_SEP$save_file") =~ s/$LOCAL_SEP+/$LOCAL_SEP/og; $bytes = $size = (stat($abs_path))[7]; $is_dir = (-d $abs_path) ? 1 : 0; if($is_dir) { $file .= $LOCAL_SEP; if($MACOS) { print $OUT sprintf("%-32s - Folder - -", $file); } else { print $OUT sprintf("%-40s %10d %-s", $file, $size, "(directory)"); } } else { ($size, $units) = Size_Units($size); if($MACOS) { ($type, $creator) = MacPerl::GetFileInfo($save_abs_path); print $OUT sprintf("%-32s %10d %5.1f %-5s %4s %4s", $file, $bytes, $size, $units, $type, $creator); } else { print $OUT sprintf("%-40s %10d %6.1f %-5s", $file, $bytes, $size, $units); } } print_wrap "\n"; $printed = 1; } } else { my($max_length, $col_width, $cols, $name, @names, $i, $j); foreach my $file (sort(readdir(DIR))) { $file =~ s/\015//g if($MACOS); next if(defined($regex) && $file !~ /^$regex$/); ($abs_path = "$path$LOCAL_SEP$file") =~ s/$LOCAL_SEP+/$LOCAL_SEP/og; $file .= $LOCAL_SEP if(-d $abs_path); push(@names, $file); $max_length = length($file) if(length($file) > $max_length); } $col_width = $max_length + 3; $col_width = 10 if($col_width < 10); $cols = int($COLS/$col_width); for($i = 0; $i <= $#names; $i += $cols) { for($j = 0; $j < $cols && defined($names[$i + $j]); $j++) { print $OUT $names[$i + $j], ' ' x ($col_width - length($names[$i + $j])); } print $OUT "\n"; } $printed = 1; } closedir(DIR); unless($printed) { if(defined($regex)) { print $OUT "No match.\n"; } else { print $OUT "\n"; } } } sub Set_Prompt { my($hlc, $prompt_ref) = @_; if(!$hlc->connected()) { $$prompt_ref = 'hlftp> '; } else { if($OPT{'p'}) { $$prompt_ref = '' } else { $$prompt_ref = "[$NICK:$ICON] " } $$prompt_ref .= $hlc->server() . '> '; } } sub Clean_Path { my($path) = shift; for($path) { s/^"(.*?)"$/$1/; s/^\\"/"/g; } $path; } sub Convert_Path { my($path) = shift; for($path) { s/\\\\/\\/g; s#(^|[^\\])/#$1:#g; s/^://; s/:$//; } $path; } sub Safe_Regex { my($re) = shift; while($$re =~ s/\(\?([^)]*)e([^)]*)\)/(?$1$2)/g){} eval { m/$$re/ }; if($@) { return undef } else { return 1 } } sub Shell_RE_To_Perl_RE { my($pre, $ignore_case) = @_; for($pre) { s/\\/\\\\/g; s/\./\\./g; s/\*/.*/g; s/\?/./g; } $pre .= '(?i)' if($ignore_case); return $pre; } sub Size_Units { my($size) = shift; return('n/a', undef) unless($size =~ /^\d+$/); my($units); if($size < 1024) { $units = 'bytes'; } elsif($size > 1024 && $size < (1024 * 1024)) { $units = 'KB'; $size = int($size/1024); } elsif($size > (1024 * 1024)) { $units = 'MB'; $size = $size/(1024 * 1024); } elsif($size > (1024 * 1024 *1024)) { $units = 'GB'; $size = $size/(1024 * 1024 *1024); } return($size, $units); } sub Date_Text { my($date) = shift; $date += HTLC_MACOS_TO_UNIX_TIME unless($MACOS); return ctime($date); } sub print_wrap { my($text) = join('', @_); print $OUT wrap("", "", $text); } OCAL_SEP/, $tmp); foreach my $dir (@dirs) { if($dir eq '..') { pop(@path) } elsif($dir eq '.') { next } elsif(length($dir)) { push(@path, $dir) } } # MacPerl's chdir() likes a trailing ':' if($MACOS) { $ret = join($LOCAL_SEP, @path) . $LOCAL_SEP; } # Other OSes have leading path separators on their absolute paths else { $ret = $LOCAL_SEP . join($LNet-Hotline-0.83/Changes010064400427010022003000000141350757122343300162600ustar00macintshalumni00000400000004Revision history for Net::Hotline 0.82 (11.27.2002) - John Siracusa * Clarified ambiguous call to rename() in Client.pm 0.82 (06.10.2002) - John Siracusa * Fixed bug if 455 (http://rt.cpan.org/NoAuth/Bug.html?id=455) by improving error handling when users don't check return values. 0.81 (05.29.2002) - John Siracusa * Fixed resume bug when downloading files from the root directory. * Added (trivial) test file. * Stopped mechanically updating version numbers in every .pm file every time there's an update. 0.80 (07.22.2001) - John Siracusa * Fixed recursion bugs in kick() and ban() in Client.pm Patch provided by Ragnar Hojland Espinosa. 0.79 (03.17.2001) - John Siracusa * Minor fixes to make -w happier, courtesy of Rodney Gordon II. 0.78 (02.12.2000) - John Siracusa * Fixed port number when uploading to servers on non-standard (i.e. not 5500) ports. Should have been fixed in 0.77. Duh. 0.77 (02.06.2000) - John Siracusa * Applied band-aid to private message reply bug when on 1.7.x servers, thanks to * Fixed port number when downloading from servers on non-standard (i.e. not 5500) ports. 0.76 (01.03.2000) - John Siracusa * Removed redundant timeout parameter in IO::Socket call, thanks to Les Brown 0.75 (11.09.1999) - John Siracusa * Bug fix in tracker_list() thanks to Les Brown 0.74 (09.06.1999) - John Siracusa * Fixed download of files greater than 31 characters in Mac OS. 0.73 (03.27.1999) - John Siracusa * Changed signal handline and eval {} blocks slightly. * Fixed a few miscellaneous bugs in hlftp.pl 0.72 (02.27.1999) - John Siracusa * Shortened internal functions name to satisfy AutoLoader on Mac OS. 0.71 (02.05.1999) - John Siracusa * Added the ban() method, ban task-type constant, and ban_handler() method. 0.70 (11.26.1998) - John Siracusa * Fixed a bug in the recv_file() method: changed the mode from "r" to "w" in a call to fdopen()...which usually helps when you're trying to create a new file. Yeesh. 0.69 (11.14.1998) - John Siracusa * Fixed bugs in the the pack() formats in the macbinary() method. 0.68 (10.21.1998) - John Siracusa * Changed return values in the get_filelist() and get_news() methods to distinguish between error return values and "empty" return values (i.e. empty directories). See the Net::Hotline::Client documentation for details. * Combined multiple pack() calls for efficiency. 0.67 (09.30.1998) - John Siracusa * Agreement text is now saved correctly in the client object. 0.66 (09.23.1998) - John Siracusa * Fixed a typo in one of the pack() templates (yikes!) * Changed behavior of the leave_handler() slightly: users are now deleted from the internal user list data strcture *before* your handler gets called. 0.65 (09.16.1998) - John Siracusa * Added private chat features. 0.64 (09.11.1998) - John Siracusa * Using the macbinary() method to convert files with no data fork to MacBinary II format now works correctly. * Miscellaneous code style changes, mostly involving variable scope and importing. * Fixed a path translation bug in the "mput" command in "hlftp.pl" 0.63 (09.09.1998) - John Siracusa * Added tracker() and tracker_list() methods. * Fixed connection timeouts and tweaked a few error messages. * Fixed failure return value in several functions: changed return(undef) to return to ensure correctness regardless of scalar or array context. * Squashed minor bugs in hlftp.pl. 0.62 (08.01.1998) - John Siracusa * Fixed a bug in the network write routine that caused it to croak during large transfers. * Added an "mput" command (and miscellaneous bug fixes) to "hlftp.pl" * Changed the Mac OS installation instructions in the REAMDE file to avoid problems with AutoLoader in MacPerl. 0.61 (07.21.1998) - John Siracusa * Fixed missing argument to substr() in User.pm (doh!) 0.60 (07.20.1998) - John Siracusa * Added file upload. * Enabled real dual-forked Mac file creation when downloading on Mac OS systems. * Blocking task mode introduced, along with a handful of blocking methods. * Overhauled error handling to work with the new blocking task mode. * Changed the network i/o (again). * Kludged up a bunch of function names to prevent AutoLoader from complaining about non-unique 8-letter(!) names. * Made a few modules less intrusive with their exporting. * Fixed a bug that caused CPAN.pm and other modules that use ExtUtils to find version numbers to die with an eval() error. * Changed the README to prevent hapless Mac OS users from overwriting MacPerl's lib/Net/ directory. * Included two example scripts: hlftp.pl and hibot.pl * In case you're wondering, I don't expect the API to completely stabilize until version 1.0. 0.51 (07.04.1998) - John Siracusa * Added file download and MacBinary II conversion. * News handler routines now make sense. * Client.pm grew large enough for me to start autoloading stuff. * Overhauled network reading routines to handle disconnects more gracefully and be robust enough to do file transfers. * Renamed a bunch of constants in Net::Hotline::Constants. 0.50 (06.23.1998) - John Siracusa * Initial release. Net-Hotline-0.83/Makefile.PL010064400427010022003000000012310757122343400167310ustar00macintshalumni00000400000004use ExtUtils::MakeMaker; unless($] >= 5.004) { print<<"EOF"; *** FATAL ERROR: TIME TO UPGRADE! *** Net::Hotline requires Perl version 5.004 or higher. The times, they are a-changing... EOF exit(1); } WriteMakefile('NAME' => 'Net::Hotline', 'PMLIBDIRS' => [ 'lib/Net/', 'lib/Net/Hotline', 'lib/Net/Hotline/Protocol' ], 'PREREQ_PM' => { 'IO::File' => 0, 'IO::Socket' => 0, 'Carp' => 0 }, 'VERSION_FROM' => 'lib/Net/Hotline.pm', 'dist' => { 'COMPRESS' => 'gzip' }); r higher. The times, they are a-changing... EOF exit(1); } WriteMakefile('NAME' => 'Net::Hotline', 'PMLIBDIRS' => [ 'lib/Net/', 'lib/Net/Hotline', 'lib/Net/Hotline/Protocol' ], 'PREREQ_PM' => { 'IO::File' => 0, 'IO::Socket' => 0, Net-Hotline-0.83/t/004070000427010022003000000000000757122352600152205ustar00macintshalumni00000400000004Net-Hotline-0.83/t/basic.t010064400427010022003000000001640757122345400164760ustar00macintshalumni00000400000004#!/usr/local/bin/perl use strict; use Test; BEGIN { plan tests => 1 } # 1: Load module use Net::Hotline; ok(1); Net-Hotline-0.83/TODO010064400427010022003000000001120757122344200154430ustar00macintshalumni00000400000004* Version 1.5+ compatibility (threaded news, etc.) * User administration.