diff --git a/Agent-Windows/.github/copilot-instructions.md b/Agent-Windows/.github/copilot-instructions.md new file mode 100644 index 00000000..b13076e3 --- /dev/null +++ b/Agent-Windows/.github/copilot-instructions.md @@ -0,0 +1,165 @@ +# GSP Agent Windows — Copilot Instructions + +**Repository purpose:** OpenGamePanel (OGP) Windows agent for managing game servers on Windows hosts. +**Prime directive:** This is a Perl-based server agent that runs on Windows to manage game server instances. It communicates with the GSP panel and handles Windows-specific game server management. + +## Architecture Overview + +### Core Components +- **`ogp_agent.pl`**: Main Perl agent daemon (same core as Linux version) +- **`agent_conf.sh`**: Configuration script adapted for Windows paths/services +- **`Install/`**: Windows-specific installation scripts and dependencies +- **Game-specific modules**: Windows game engine handlers and integrations +- **Windows Service integration**: Can run as Windows service + +### Key Directories & Their Purpose +- **`Cfg/`**: Configuration file parsers (Windows path handling) +- **`Crypt/`**: Encryption and security modules for panel communication +- **`File/`**: File management with Windows filesystem support +- **`FastDownload/`**: Download acceleration for Windows game content +- **`Minecraft/`**: Minecraft server management (Windows .bat files) +- **`ArmaBE/`**: Arma server BattlEye integration for Windows +- **`ServerFiles/`**: Windows game server executables and libraries +- **`Schedule/`**: Windows Task Scheduler integration +- **`Install/`**: Windows-specific installation components + +## Windows-Specific Considerations + +### Path Management +- **Drive letters**: Handle C:\, D:\ drive specifications properly +- **Path separators**: Use Windows backslash paths internally +- **UNC paths**: Support network share paths for distributed storage +- **Long paths**: Handle Windows long path limitations (>260 characters) + +### Process Management +- **Windows Services**: Integration with Windows Service Control Manager +- **Process isolation**: Run game servers in separate Windows sessions +- **Registry access**: Read Windows registry for game installation paths +- **UAC handling**: Proper User Account Control integration + +### Windows Game Engines +- **Steam games**: SteamCMD integration on Windows +- **Windows-only games**: Support for .exe-based game servers +- **DirectX dependencies**: Manage Visual C++ redistributables +- **.NET Framework**: Handle .NET game server requirements + +## Development Guidelines + +### Windows Perl Environment +- **Strawberry Perl**: Recommended Perl distribution for Windows +- **ActivePerl compatibility**: Support both major Perl distributions +- **Windows modules**: Use Win32:: modules for Windows-specific operations +- **Path handling**: Use File::Spec for cross-platform path operations + +### Security Requirements +- **Windows Defender**: Whitelist agent and game executables +- **Firewall integration**: Windows Firewall rule management +- **User privileges**: Run with appropriate Windows user rights +- **File permissions**: NTFS permission management for game directories + +### Service Integration +- **Windows Services**: Install agent as proper Windows service +- **Event logging**: Use Windows Event Log for system integration +- **Startup types**: Support automatic/manual service startup +- **Service recovery**: Configure service recovery options + +## Critical Implementation Patterns + +### Windows Path Handling +```perl +# Always use proper Windows path handling +use File::Spec; +use Cwd; + +sub normalize_windows_path { + my ($path) = @_; + $path = File::Spec->canonpath($path); + return $path; +} + +# Convert panel paths to Windows format +sub panel_to_windows_path { + my ($unix_path) = @_; + $unix_path =~ s|/|\\|g; # Convert forward slashes + return $unix_path; +} +``` + +### Process Management on Windows +```perl +# Windows-specific process spawning +sub start_windows_server { + my ($home_id, $executable, $args) = @_; + + # Use proper Windows process creation + my $cmd = qq{"$executable" $args}; + my $pid = system(1, $cmd); # Non-blocking system call + + return $pid; +} +``` + +### Registry Access Example +```perl +# Read game installation paths from Windows Registry +use Win32::Registry; + +sub get_steam_path { + my $steam_key; + $HKEY_LOCAL_MACHINE->Open("SOFTWARE\\Valve\\Steam", $steam_key) or return undef; + + my $install_path; + $steam_key->QueryValueEx("InstallPath", my $type, $install_path); + $steam_key->Close(); + + return $install_path; +} +``` + +## Windows-Specific Features + +### Service Installation +- **sc.exe integration**: Use Windows Service Control for service management +- **NSSM support**: Non-Sucking Service Manager for complex services +- **Service dependencies**: Handle service dependency chains +- **Service accounts**: Run under appropriate service accounts + +### Windows Firewall Management +- **Port rules**: Automatically create firewall rules for game ports +- **Program exceptions**: Add game executables to firewall exceptions +- **Profile management**: Handle different firewall profiles (domain/private/public) + +### Game Server Specifics +- **Windows game paths**: Support typical Windows game installation locations +- **DLL dependencies**: Handle game DLL requirements and redistributables +- **Windows-only features**: Support Windows-specific game server features +- **Performance counters**: Use Windows performance monitoring + +## Common Windows Issues to Avoid +1. **Path length limits**: Handle Windows 260-character path limitation +2. **Permission escalation**: Avoid unnecessary UAC prompts +3. **Service isolation**: Ensure proper service isolation and security +4. **Registry pollution**: Clean registry entries on uninstall +5. **DLL hell**: Manage game DLL conflicts and dependencies +6. **Windows Updates**: Handle Windows Update service interactions +7. **Antivirus conflicts**: Manage antivirus software interactions + +## Integration with GSP Panel +- **Same API**: Uses identical panel communication as Linux agent +- **Windows paths**: Translate Unix paths from panel to Windows format +- **File uploads**: Handle Windows-specific file upload scenarios +- **Process monitoring**: Windows-specific process and resource monitoring + +## Installation Requirements +- **Perl environment**: Strawberry Perl or ActivePerl +- **Windows dependencies**: Visual C++ redistributables, .NET Framework +- **Network access**: Outbound HTTPS for panel communication +- **Admin privileges**: Initial installation requires administrator rights +- **Firewall configuration**: Inbound rules for game server ports + +## Testing on Windows +- **Windows versions**: Test on Windows Server 2019/2022 and Windows 10/11 +- **Permission scenarios**: Test with different user privilege levels +- **Antivirus testing**: Validate with common antivirus software +- **Game compatibility**: Test with Windows-specific game servers +- **Service reliability**: Long-running service stability testing \ No newline at end of file diff --git a/Agent-Windows/ArmaBE/ArmaBE.pm b/Agent-Windows/ArmaBE/ArmaBE.pm new file mode 100644 index 00000000..da447396 --- /dev/null +++ b/Agent-Windows/ArmaBE/ArmaBE.pm @@ -0,0 +1,198 @@ +# ArmaBE - Perl extension BattlEye ARMA Rcon interface +# Original Source for BattlEye source - https://github.com/Jaegerhaus/BE-RCon-Tools +# +# $Id:$ +# + +package ArmaBE; + +use strict; +use warnings; +use IO::Socket::INET; + +# release version +our $VERSION = "0.01"; + +# create class +sub new { + my $class = shift; + + # create object with defaults + my $self = { + hostname => undef, + port => 27015, + password => undef, + timeout => 5, + connected => 0, + authenticated => 0, + socket => undef, + sequence => 0, + }; + + # create object + bless($self, $class); + + # initialize class instances + $self->init(); + + # parse constructor args + while (my ($key, $val) = splice(@_, 0, 2)) { + $key = lc($key); + if ($key eq "hostname") { $self->hostname($val) } + elsif ($key eq "port") { $self->port($val) } + elsif ($key eq "password") { $self->password($val) } + elsif ($key eq "timeout") { $self->timeout($val) } + else { print STDERR "Unknown attribute: $key\n" } + } + + return $self; +} + +# initialize class instances +sub init { + my $self = shift; + my $class = ref($self); + + # manipulate symbol table.. gotta love perl + no strict "refs"; + no warnings; + foreach my $instance (keys %$self) { + *{"${class}::${instance}"} = sub { + my $self = shift; + my $value = shift; + my $ref = \$self->{$instance}; + if (defined $value) { + $$ref = $value; + return $self; + } else { + return $$ref; + } + }; + } +} + +# run a command and return its response +sub run { + my $self = shift; + my $command = shift; + + if (!$self->connected()) { + $self->connect(); + } + + if (!$self->authenticated()) { + $self->authenticate(); + } + + if ($self->authenticated()) { + my $socket = $self->socket(); + print $socket $self->packet("\1\0".$command); + return 1; + } else { + return 0; + } +} + +# create tcp socket +sub connect { + my $self = shift; + + my $socket = IO::Socket::INET->new( + PeerAddr => $self->hostname(), + PeerPort => $self->port(), + Timeout => $self->timeout(), + Proto => "udp", + ) || die "Failed to connect: $!\n"; + + $self->socket($socket); + $self->connected(1); +} + +# authenticate rcon session +sub authenticate { + my $self = shift; + + # send authentication packet to server + my $socket = $self->socket(); + print $socket $self->packet("\0".$self->password()); + + my $response = $self->response(); + my $authenticated = int(substr($response, -1)); + + $self->authenticated($authenticated); +} + +###################### +# PROTOCOL FUNCTIONS # +###################### + +# rcon command protocol: +# https://www.battleye.com/downloads/BERConProtocol.txt + +sub crc32 { + my ($self,$input,$init_value,$polynomial) = @_; + + $init_value = 0 unless (defined $init_value); + $polynomial = 0xedb88320 unless (defined $polynomial); + + my @lookup_table; + + for (my $i=0; $i<256; $i++) { + my $x = $i; + for (my $j=0; $j<8; $j++) { + if ($x & 1) { + $x = ($x >> 1) ^ $polynomial; + } else { + $x = $x >> 1; + } + } + push @lookup_table, $x; + } + + my $crc = $init_value ^ 0xffffffff; + + foreach my $x (unpack ('C*', $input)) { + $crc = (($crc >> 8) & 0xffffff) ^ $lookup_table[ ($crc ^ $x) & 0xff ]; + } + + $crc = $crc ^ 0xffffffff; + + return $crc; +} + +# create a packet of type (AUTH or CMD) +sub packet { + my $self = shift; + my $payload = shift; + + my $break = pack('C', 0xff); + my $packet = "BE" + . pack('V', $self->crc32($break . $payload)) + . $break + . $payload; + + return $packet; +} + +# receive packet +sub response { + my $self = shift; + my $payload = $self->read(); + + return $payload; +} + +# read length of bytes from socket with timeout +sub read { + my $self = shift; + my $received; + my $socket = $self->socket(); + + $socket->recv($received, 9); + + return unpack('H*', $received); +} + +1; + +__END__ diff --git a/Agent-Windows/COPYING b/Agent-Windows/COPYING new file mode 100644 index 00000000..d511905c --- /dev/null +++ b/Agent-Windows/COPYING @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Agent-Windows/Cfg/empty.txt b/Agent-Windows/Cfg/empty.txt new file mode 100644 index 00000000..e69de29b diff --git a/Agent-Windows/Crypt/XXTEA.pm b/Agent-Windows/Crypt/XXTEA.pm new file mode 100644 index 00000000..b217edbe --- /dev/null +++ b/Agent-Windows/Crypt/XXTEA.pm @@ -0,0 +1,230 @@ +#/**********************************************************\ +#| | +#| The implementation of PHPRPC Protocol 3.0 | +#| | +#| xxtea.pm | +#| | +#| Release 3.0.0 beta | +#| Copyright (c) 2005-2007 by Team-PHPRPC | +#| | +#| WebSite: http://www.phprpc.org/ | +#| http://www.phprpc.net/ | +#| http://www.phprpc.com/ | +#| http://sourceforge.net/projects/php-rpc/ | +#| | +#| Author: Ma Bingyao | +#| | +#| This file may be distributed and/or modified under the | +#| terms of the GNU Lesser General Public License (LGPL) | +#| version 3.0 as published by the Free Software Foundation | +#| and appearing in the included file LICENSE. | +#| | +#\**********************************************************/ +# +# XXTEA encryption arithmetic module. +# +# Copyright (C) 2006-2007 Ma Bingyao +# Version: 1.00 +# LastModified: Nov 7, 2007 +# This library is free. You can redistribute it and/or modify it. +# + +package Crypt::XXTEA; + +use bytes; +use integer; +use strict; + +use Exporter; +use vars qw($VERSION @ISA @EXPORT); + +$VERSION = 1.00; +@ISA = qw(Exporter); +@EXPORT = qw(xxtea_encrypt xxtea_decrypt); + +*encrypt = \&xxtea_encrypt; +*decrypt = \&xxtea_decrypt; + +sub _long2str { + my ($v, $w) = @_; + my $len = @{$v}; + my $n = ($len - 1) << 2; + if ($w) { + my $m = $v->[$len - 1]; + if (($m < $n - 3) || ($m > $n)) { + return 0; + } + $n = $m; + } + my @s = (); + for (my $i = 0; $i < $len; $i++) { + $s[$i] = pack("V", $v->[$i]); + } + if ($w) { + return substr(join('', @s), 0, $n); + } + else { + return join('', @s); + } +} + +sub _str2long { + my ($s, $w) = @_; + my @v = unpack("V*", $s. "\0"x((4 - length($s) % 4) & 3)); + if ($w) { + $v[@v] = length($s); + } + return @v; +} + +sub xxtea_encrypt { + my ($s, $k) = @_; + if ($s eq "") { + return ""; + } + my @v = _str2long($s, 1); + my @k = _str2long($k, 0); + if (@k < 4) { + for (my $i = @k; $i < 4; $i++) { + $k[$i] = 0; + } + } + my $n = $#v; + my $z = $v[$n]; + my $y = $v[0]; + my $delta = 0x9E3779B9; + my $q = 6 + 52 / ($n + 1); + my $sum = 0; + my $e; + my $p; + my $mx; + while (0 < $q--) { + $sum = ($sum + $delta) & 0xffffffff; + $e = $sum >> 2 & 3; + for ($p = 0; $p < $n; $p++) { + $y = $v[$p + 1]; + $mx = ((($z >> 5 & 0x07ffffff) ^ $y << 2) + (($y >> 3 & 0x1fffffff) ^ $z << 4)) ^ (($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z)) & 0xffffffff; + $z = $v[$p] = ($v[$p] + $mx) & 0xffffffff; + } + $y = $v[0]; + $mx = ((($z >> 5 & 0x07ffffff) ^ $y << 2) + (($y >> 3 & 0x1fffffff) ^ $z << 4)) ^ (($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z)) & 0xffffffff; + $z = $v[$n] = ($v[$n] + $mx) & 0xffffffff; + } + return _long2str(\@v, 0); +} + +sub xxtea_decrypt { + my ($s, $k) = @_; + if ($s eq "") { + return ""; + } + my @v = _str2long($s, 0); + my @k = _str2long($k, 0); + if (@k < 4) { + for (my $i = @k; $i < 4; $i++) { + $k[$i] = 0; + } + } + my $n = $#v; + my $z = $v[$n]; + my $y = $v[0]; + my $delta = 0x9E3779B9; + my $q = 6 + 52 / ($n + 1); + my $sum = ($q * $delta) & 0xffffffff; + my $e; + my $p; + my $mx; + while ($sum != 0) { + $e = $sum >> 2 & 3; + for ($p = $n; $p > 0; $p--) { + $z = $v[$p - 1]; + $mx = ((($z >> 5 & 0x07ffffff) ^ $y << 2) + (($y >> 3 & 0x1fffffff) ^ $z << 4)) ^ (($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z)) & 0xffffffff; + $y = $v[$p] = ($v[$p] - $mx) & 0xffffffff; + } + $z = $v[$n]; + $mx = ((($z >> 5 & 0x07ffffff) ^ $y << 2) + (($y >> 3 & 0x1fffffff) ^ $z << 4)) ^ (($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z)) & 0xffffffff; + $y = $v[0] = ($v[0] - $mx) & 0xffffffff; + $sum = ($sum - $delta) & 0xffffffff; + } + return _long2str(\@v, 1); +} + +1; + +__END__ + +=head1 NAME + +Crypt::XXTEA - XXTEA encryption arithmetic module. + +=head1 SYNOPSIS + + use Crypt::XXTEA; + +=head1 DESCRIPTION + +XXTEA is a secure and fast encryption algorithm. It's suitable for web development. This module allows you to encrypt or decrypt a string using the algorithm. + +=head1 FUNCTIONS + +=over 4 + +=item xxtea_encrypt + + my $ciphertext = xxtea_encrypt($plaintext, $key); + +This function encrypts $plaintext using $key and returns the $ciphertext. + +=item encrypt + + my $ciphertext = Crypt::XXTEA::encrypt($plaintext, $key); + +This function is the same as xxtea_encrypt. + +=item xxtea_decrypt + + my $plaintext = xxtea_decrypt($ciphertext, $key); + +This function decrypts $ciphertext using $key and returns the $plaintext. + +=item decrypt + + my $plaintext = Crypt::XXTEA::decrypt($ciphertext, $key); + +This function is the same as xxtea_decrypt. + +=back + +=head1 EXAMPLE + + use Crypt::XXTEA; + my $ciphertext = xxtea_encrypt("Hello XXTEA.", "1234567890abcdef"); + my $plaintext = xxtea_decrypt($ciphertext, "1234567890abcdef"); + print $plaintext; + + $ciphertext = Crypt::XXTEA::encrypt("Hi XXTEA.", "1234567890abcdef"); + $plaintext = Crypt::XXTEA::decrypt($ciphertext, "1234567890abcdef"); + print $plaintext; + +=head1 NOTES + +If $plaintext is equal to "", it returns "". + +It returns 0 when fails to decrypt. + +Only the first 16 bytes of $key is used. if $key is shorter than 16 bytes, it will be padding \0. + +The XXTEA algorithm is stronger and faster than Crypt::DES, Crypt::Blowfish & Crypt::IDEA. + +=head1 SEE ALSO + +Crypt::DES +Crypt::Blowfish +Crypt::IDEA + +=head1 COPYRIGHT + +The implementation of the XXTEA algorithm was developed by, +and is copyright of, Ma Bingyao (andot@ujn.edu.cn). + +=cut diff --git a/Agent-Windows/DEVELOPMENT b/Agent-Windows/DEVELOPMENT new file mode 100644 index 00000000..0be27316 --- /dev/null +++ b/Agent-Windows/DEVELOPMENT @@ -0,0 +1,6 @@ +OGP Agent NOTES: + +Before committing code it is recommended to execute perltidy: + +$ perltidy -b -gnu ogp_agent.pl + diff --git a/Agent-Windows/EHCP/addAccount.php b/Agent-Windows/EHCP/addAccount.php new file mode 100644 index 00000000..f65bb26e --- /dev/null +++ b/Agent-Windows/EHCP/addAccount.php @@ -0,0 +1,129 @@ += 2 && $rDir[strlen($rDir) - 1] == "/") { + $end = strlen($rDir) - 2; + $rDir = substr($rDir, 0, $end); + } + + if ($errorCount == 0) { + + // Security checks + $ftp_password_db = escapeSQLStr($ftp_pass, $connection); + $ftp_username_db = escapeSQLStr($ftp_username, $connection); + $rDir = escapeSQLStr($rDir, $connection); + $SQL = "SELECT id FROM ftpaccounts WHERE ftpusername = '$ftp_username_db'"; + $Result = execSQL($SQL, $connection); + + if ($Result !== FALSE) { + $count = countSQLResult($Result); + + if ($count > 0) { + $errorCount++; + $errors[] = "The FTP username supplied already exists!  Please enter another unique username!"; + } else { + + // Make sure data enter is unique for homedir + $SQL = "SELECT id FROM ftpaccounts WHERE homedir = '$rDir'"; + $Result = execSQL($SQL, $connection); + + if ($Result !== FALSE) { + $count = countSQLResult($Result); + + // Insert the data into the + $SQL = "INSERT INTO ftpaccounts (ftpusername, password, homedir) VALUES ('$ftp_username_db', password('$ftp_password_db'), '$rDir')"; + $Result = execSQL($SQL, $connection); + + if ($Result !== FALSE) { + $success = 1; + } else { + $errorCount++; + $errors[] = getSQLError($connection); + } + } else { + $errorCount++; + $errors[] = getSQLError($connection); + } + + if ($errorCount > 0 && $success == 0) { + unset($_POST['createFTP']); + include 'admin/ftpCreateForm.php'; + } + } + } else { + $errorCount++; + $errors[] = getSQLError($connection); + } + } +} + +// Log errors + +if ($errorCount > 0) { + addToLog($errors); +} + +// Return value: +echo $success; +?> diff --git a/Agent-Windows/EHCP/config.php b/Agent-Windows/EHCP/config.php new file mode 100644 index 00000000..b4519a21 --- /dev/null +++ b/Agent-Windows/EHCP/config.php @@ -0,0 +1,83 @@ + diff --git a/Agent-Windows/EHCP/db_functions.php b/Agent-Windows/EHCP/db_functions.php new file mode 100644 index 00000000..592ef05f --- /dev/null +++ b/Agent-Windows/EHCP/db_functions.php @@ -0,0 +1,53 @@ + diff --git a/Agent-Windows/EHCP/delAccount.php b/Agent-Windows/EHCP/delAccount.php new file mode 100644 index 00000000..478cc009 --- /dev/null +++ b/Agent-Windows/EHCP/delAccount.php @@ -0,0 +1,59 @@ + 0) { + addToLog($errors); +} + +// Return value: +echo $success; +?> diff --git a/Agent-Windows/EHCP/ehcp_ftp_log.txt b/Agent-Windows/EHCP/ehcp_ftp_log.txt new file mode 100644 index 00000000..e69de29b diff --git a/Agent-Windows/EHCP/listAllUsers.php b/Agent-Windows/EHCP/listAllUsers.php new file mode 100644 index 00000000..be4e1e7e --- /dev/null +++ b/Agent-Windows/EHCP/listAllUsers.php @@ -0,0 +1,66 @@ + 0) { + + while ($row = getSQLRow($Result)) { + + // Only show custom entries... do not allow to modify EHCP accounts. + // domainname field will be NULL for custom FTP entries + + if (!empty($row['homedir']) && (empty($row['domainname']) || $row['domainname'] === NULL) && (empty($row['status']) || $row['status'] === NULL)) { + $countNotNull++; + $username = $row['ftpusername']; + $dir = $row['homedir']; + $users_list.= $username . "\t" . $dir . "/./\n"; + } + } + + if ($countNotNull == 0) { + $errorCount++; + $errors[] = "There are no custom FTP accounts yet in the EHCP database!"; + } + } else { + $errorCount++; + $errors[] = "No FTP accounts exist from the ftpaccounts table!"; + } + } else { + $errorCount++; + $errors[] = getSQLError($connection); + $success = 0; + } + + // Log errors + + if ($errorCount > 0) { + addToLog($errors); + } +} + +// Return the user list +echo $users_list; +?> diff --git a/Agent-Windows/EHCP/showAccount.php b/Agent-Windows/EHCP/showAccount.php new file mode 100644 index 00000000..34685aa5 --- /dev/null +++ b/Agent-Windows/EHCP/showAccount.php @@ -0,0 +1,66 @@ + 0) { + addToLog($errors); + } +} + +// Return the user list +echo $user_details; +?> diff --git a/Agent-Windows/EHCP/syncftp.php b/Agent-Windows/EHCP/syncftp.php new file mode 100644 index 00000000..9a1ab99a --- /dev/null +++ b/Agent-Windows/EHCP/syncftp.php @@ -0,0 +1,11 @@ +connectTodb(); # fill config.php with db user/pass for things to work.. + + $app->addDaemonOp('syncftp', '', '', '', 'sync ftp for nonstandard homes'); +} +chdir($curDir); +?> diff --git a/Agent-Windows/EHCP/updateInfo.php b/Agent-Windows/EHCP/updateInfo.php new file mode 100644 index 00000000..d57cbaee --- /dev/null +++ b/Agent-Windows/EHCP/updateInfo.php @@ -0,0 +1,144 @@ + 2 && $update_dir[strlen($update_dir) - 1] == "/") { + $end = strlen($update_dir) - 2; + $update_dir = substr($update_dir, 0, $end); + } + + if ($errorCount == 0) { + + // Security checks + + if (isset($ftp_pass)) { + $ftp_password_db = escapeSQLStr($ftp_pass, $connection); + } + + $ftp_username_db = escapeSQLStr($ftp_username, $connection); + + $SQL = "SELECT * FROM ftpaccounts WHERE ftpusername = '$ftp_username_db'"; + + $Result = execSQL($SQL, $connection); + + if ($Result !== FALSE) { + $count = countSQLResult($Result); + if ($count != 1) { + $errorCount++; + $errors[] = "FTP User " . $ftp_username . " does not exist in the database. Account information cannot be updated"; + } else { + + // Update user's password data into DB: + $SQL = "UPDATE ftpaccounts SET "; + + if (isset($ftp_password_db)) { + $SQL.= "password=password('$ftp_password_db'), "; + } + $SQL.= "homedir='$update_dir' WHERE ftpusername='$ftp_username_db'"; + $Result = execSQL($SQL, $connection); + + if ($Result !== FALSE) { + $success = 1; + } else { + $errorCount++; + $errors[] = getSQLError($connection); + } + } + } else { + $errorCount++; + $errors[] = getSQLError($connection); + } + } +} + +// Log errors + +if ($errorCount > 0) { + addToLog($errors); +} + +// Return value: +echo $success; +?> diff --git a/Agent-Windows/EHCP/updatePass.php b/Agent-Windows/EHCP/updatePass.php new file mode 100644 index 00000000..640c7888 --- /dev/null +++ b/Agent-Windows/EHCP/updatePass.php @@ -0,0 +1,76 @@ + 0) { + addToLog($errors); +} + +// Return value: +echo $success; +?> diff --git a/Agent-Windows/FastDownload/ForkedDaemon.pm b/Agent-Windows/FastDownload/ForkedDaemon.pm new file mode 100644 index 00000000..f2e1212d --- /dev/null +++ b/Agent-Windows/FastDownload/ForkedDaemon.pm @@ -0,0 +1,333 @@ +use strict; +use warnings; +use lib "."; +use FastDownload::Settings; # Daemon Settings +use Cwd; # Fast way to get the current directory +use Fcntl ':flock'; # Import LOCK_* constants for file locking +use File::Copy; # Simple file copy functions +use Path::Class::File; # Handle files and directories. +use HTTP::Daemon; # Create the Fast Download Daemon. +use URI::Escape; # Translate url code for example: %20 to space +use Socket qw( inet_aton ); # Work with network addresses. + +use constant RUN_DIR => getcwd(); +use constant FD_DIR => Path::Class::Dir->new(RUN_DIR, 'FastDownload'); +use constant FD_ALIASES_DIR => Path::Class::Dir->new(FD_DIR, 'aliases'); +use constant FD_PID_FILE => Path::Class::File->new(FD_DIR, 'fd.pid'); +use constant FD_LOG_FILE => Path::Class::File->new(FD_DIR, 'fastdownload.log'); + +### Logger function. +### @param line the line that is put to the log file. +sub logger +{ + my $logcmd = $_[0]; + my $also_print = 0; + + if (@_ == 2) + { + ($also_print) = $_[1]; + } + + $logcmd = localtime() . " $logcmd\n"; + + if ($also_print == 1) + { + print "$logcmd"; + } + + open(LOGFILE, '>>', FD_LOG_FILE) + or die("Can't open " . FD_LOG_FILE . " - $!"); + flock(LOGFILE, LOCK_EX) or die("Failed to lock log file."); + seek(LOGFILE, 0, 2) or die("Failed to seek to end of file."); + print LOGFILE "$logcmd" or die("Failed to write to log file."); + flock(LOGFILE, LOCK_UN) or die("Failed to unlock log file."); + close(LOGFILE) or die("Failed to close log file."); +} + +# Rotate the log file +if (-e FD_LOG_FILE) +{ + if (-e FD_LOG_FILE . ".bak") + { + unlink(FD_LOG_FILE . ".bak"); + } + logger "Rotating log file"; + move(FD_LOG_FILE, FD_LOG_FILE . ".bak"); + logger "New log file created"; +} + +if (open(PIDFILE, '>', FD_PID_FILE)) +{ + print PIDFILE $$; + close(PIDFILE); +} + +$SIG{'PIPE'} = 'IGNORE'; + +my $fd = HTTP::Daemon->new(LocalAddr=>$FastDownload::Settings{ip}, + LocalPort=>$FastDownload::Settings{port}, + ReuseAddr=>'1') || die; + +logger "Fast Download Daemon Started at: url . "> - PID $$",1; + +my %aliases; +if(-d FD_ALIASES_DIR) +{ + if( !opendir(ALIASES, FD_ALIASES_DIR) ) + { + logger "Error openning aliases directory " . FD_ALIASES_DIR . ", $!"; + } + else + { + while (my $alias = readdir(ALIASES)) + { + # Skip . and .. + next if $alias =~ /^\./; + if( !open(ALIAS, '<', Path::Class::Dir->new(FD_ALIASES_DIR, $alias)) ) + { + logger "Error reading alias '$alias', $!"; + } + else + { + my @file_lines = (); + my $i = 0; + while () + { + chomp $_; + $file_lines[$i] = $_; + $i++; + } + close(ALIAS); + $aliases{$alias}{home} = $file_lines[0]; + $aliases{$alias}{match_file_extension} = $file_lines[1]; + $aliases{$alias}{match_client_ip} = $file_lines[2]; + } + } + closedir(ALIASES); + } +} +else +{ + logger "Aliases directory '" . FD_ALIASES_DIR . "' does not exist or is inaccessible."; +} + +$SIG{CHLD} = 'IGNORE'; +while (my $c = $fd->accept) { + my $pid = fork(); + if (not defined $pid) + { + logger "Could not allocate resources for Fast Download Client.",1; + } + # Only the forked child goes here. + elsif ($pid == 0) + { + if(%aliases) + { + while(my $r = $c->get_request) { + process_client_request($FastDownload::Settings{listing}, $r, $c); + $c->close; + } + } + else + { + while(my $r = $c->get_request) { + $c->send_error(403,""); + $c->close; + } + } + undef($c); + # Child process must exit. + exit(0); + } +} + +sub process_client_request +{ + my($listing, $r, $c) = @_; + my @uri_alias = split /\//, $r->uri->path; + if(defined $uri_alias[1]) + { + my $alias = $uri_alias[1]; + if ($r->method eq 'GET' and defined $aliases{$alias}) + { + my $home = $aliases{$alias}{home}; + my (@extensions,@subnets); + if(defined $aliases{$alias}{match_file_extension}) + { + @extensions = split /,/, $aliases{$alias}{match_file_extension}; + } + if(defined $aliases{$alias}{match_client_ip}) + { + @subnets = split /,/, $aliases{$alias}{match_client_ip}; + } + my $client = getpeername($c); + my ($port, $iaddr) = unpack_sockaddr_in($client); + my $client_ip = inet_ntoa($iaddr); + my $uri = uri_unescape($r->uri->path); + my $escaped_alias = "\/" . $alias; + $uri =~ s/^$escaped_alias//g; + my $location = $home . $uri; + my $is_subnet; + if(!grep {defined($_)} @subnets) + { + $is_subnet = 1; + } + else + { + foreach my $subnet (@subnets) + { + $is_subnet = in_subnet($client_ip, $subnet); + if($is_subnet) + { + last; + } + } + } + if($is_subnet) + { + if(-d $location) + { + my $index = $location . "/" . "index.html"; + if(-f $index) + { + $c->send_file_response($index); + } + else + { + if($listing == 1) + { + # Loop through all files and folders + my @dirs = (); + my @bins = (); + my @files = (); + opendir(DIR, $location); + while (my $entry = readdir(DIR)) + { + # Skip . and .. + next if $entry =~ /^\./; + my $link_location = $location."/".$entry; + if(-d $link_location) + { + push(@dirs, $entry); + } + elsif(-B $link_location) + { + push(@bins, $entry); + } + else + { + push(@files, $entry); + } + } + closedir(DIR); + @dirs = sort @dirs; + @bins = sort @bins; + @files = sort @files; + my ($content, $href); + foreach my $dir (@dirs) + { + $href = Path::Class::Dir->new($r->uri->path, $dir); + $content .= "".$dir."
"; + } + foreach my $bin (@bins) + { + $href = Path::Class::File->new($r->uri->path, $bin); + $content .= "".$bin."
"; + } + foreach my $file (@files) + { + $href = Path::Class::File->new($r->uri->path, $file); + $content .= "".$file."
"; + } + my $response = HTTP::Response->new(200); + $response->content($content); + $response->header("Content-Type" => "text/html"); + $c->send_response($response); + } + else + { + $c->send_error(403,""); + } + } + } + else + { + my @extension = split /\./, $uri; + my $extension = $extension[-1]; + if(grep {$_ eq $extension} @extensions or !grep {defined($_)} @extensions) + { + $c->send_file_response($location); + } + else + { + $c->send_error(403,""); + } + } + } + else + { + $c->send_error(403,""); + } + } + else + { + $c->send_error(403,""); + } + } + else + { + $c->send_error(403,""); + } +} + +sub ip2long($) +{ + return( unpack( 'N', inet_aton(shift) ) ); +} + +sub in_subnet($$) +{ + my $ip = shift; + my $subnet = shift; + my $ip_long = ip2long( $ip ); + if( $subnet=~m|(^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})/(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$| ) + { + my $subnet = ip2long($1); + my $mask = ip2long($2); + if( ($ip_long & $mask)==$subnet ) + { + return 1; + } + } + elsif( $subnet=~m|(^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})/(\d{1,2})$| ) + { + my $subnet = ip2long($1); + my $bits = $2; + my $mask = -1<<(32-$bits); + $subnet&= $mask; + if( ($ip_long & $mask)==$subnet ) + { + return 1; + } + } + elsif( $subnet=~m|(^\d{1,3}\.\d{1,3}\.\d{1,3}\.)(\d{1,3})-(\d{1,3})$| ) + { + my $start_ip = ip2long($1.$2); + my $end_ip = ip2long($1.$3); + if( $start_ip<=$ip_long and $end_ip>=$ip_long ) + { + return 1; + } + } + elsif( $subnet=~m|^[\d\*]{1,3}\.[\d\*]{1,3}\.[\d\*]{1,3}\.[\d\*]{1,3}$| ) + { + my $search_string = $subnet; + $search_string=~s/\./\\\./g; + $search_string=~s/\*/\.\*/g; + if( $ip=~/^$search_string$/ ) + { + return 1; + } + } + return 0; +} \ No newline at end of file diff --git a/Agent-Windows/File/Copy/Recursive.pm b/Agent-Windows/File/Copy/Recursive.pm new file mode 100644 index 00000000..f0e7d581 --- /dev/null +++ b/Agent-Windows/File/Copy/Recursive.pm @@ -0,0 +1,696 @@ +package File::Copy::Recursive; + +use strict; +BEGIN { + # Keep older versions of Perl from trying to use lexical warnings + $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006; +} +use warnings; + +use Carp; +use File::Copy; +use File::Spec; #not really needed because File::Copy already gets it, but for good measure :) + +use vars qw( + @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink + $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir + $CondCopy $BdTrgWrn $SkipFlop $DirPerms +); + +require Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir); +$VERSION = '0.38'; + +$MaxDepth = 0; +$KeepMode = 1; +$CPRFComp = 0; +$CopyLink = eval { local $SIG{'__DIE__'};symlink '',''; 1 } || 0; +$PFSCheck = 1; +$RemvBase = 0; +$NoFtlPth = 0; +$ForcePth = 0; +$CopyLoop = 0; +$RMTrgFil = 0; +$RMTrgDir = 0; +$CondCopy = {}; +$BdTrgWrn = 0; +$SkipFlop = 0; +$DirPerms = 0777; + +my $samecheck = sub { + return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders... + return if @_ != 2 || !defined $_[0] || !defined $_[1]; + return if $_[0] eq $_[1]; + + my $one = ''; + if($PFSCheck) { + $one = join( '-', ( stat $_[0] )[0,1] ) || ''; + my $two = join( '-', ( stat $_[1] )[0,1] ) || ''; + if ( $one eq $two && $one ) { + carp "$_[0] and $_[1] are identical"; + return; + } + } + + if(-d $_[0] && !$CopyLoop) { + $one = join( '-', ( stat $_[0] )[0,1] ) if !$one; + my $abs = File::Spec->rel2abs($_[1]); + my @pth = File::Spec->splitdir( $abs ); + while(@pth) { + my $cur = File::Spec->catdir(@pth); + last if !$cur; # probably not necessary, but nice to have just in case :) + my $two = join( '-', ( stat $cur )[0,1] ) || ''; + if ( $one eq $two && $one ) { + # $! = 62; # Too many levels of symbolic links + carp "Caught Deep Recursion Condition: $_[0] contains $_[1]"; + return; + } + + pop @pth; + } + } + + return 1; +}; + +my $glob = sub { + my ($do, $src_glob, @args) = @_; + + local $CPRFComp = 1; + + my @rt; + for my $path ( glob($src_glob) ) { + my @call = [$do->($path, @args)] or return; + push @rt, \@call; + } + + return @rt; +}; + +my $move = sub { + my $fl = shift; + my @x; + if($fl) { + @x = fcopy(@_) or return; + } else { + @x = dircopy(@_) or return; + } + if(@x) { + if($fl) { + unlink $_[0] or return; + } else { + pathrmdir($_[0]) or return; + } + if($RemvBase) { + my ($volm, $path) = File::Spec->splitpath($_[0]); + pathrm(File::Spec->catpath($volm,$path,''), $ForcePth, $NoFtlPth) or return; + } + } + return wantarray ? @x : $x[0]; +}; + +my $ok_todo_asper_condcopy = sub { + my $org = shift; + my $copy = 1; + if(exists $CondCopy->{$org}) { + if($CondCopy->{$org}{'md5'}) { + + } + if($copy) { + + } + } + return $copy; +}; + +sub fcopy { + $samecheck->(@_) or return; + if($RMTrgFil && (-d $_[1] || -e $_[1]) ) { + my $trg = $_[1]; + if( -d $trg ) { + my @trgx = File::Spec->splitpath( $_[0] ); + $trg = File::Spec->catfile( $_[1], $trgx[ $#trgx ] ); + } + $samecheck->($_[0], $trg) or return; + if(-e $trg) { + if($RMTrgFil == 1) { + unlink $trg or carp "\$RMTrgFil failed: $!"; + } else { + unlink $trg or return; + } + } + } + my ($volm, $path) = File::Spec->splitpath($_[1]); + if($path && !-d $path) { + pathmk(File::Spec->catpath($volm,$path,''), $NoFtlPth); + } + if( -l $_[0] && $CopyLink ) { + carp "Copying a symlink ($_[0]) whose target does not exist" + if !-e readlink($_[0]) && $BdTrgWrn; + symlink readlink(shift()), shift() or return; + } else { + copy(@_) or return; + + my @base_file = File::Spec->splitpath($_[0]); + my $mode_trg = -d $_[1] ? File::Spec->catfile($_[1], $base_file[ $#base_file ]) : $_[1]; + + chmod scalar((stat($_[0]))[2]), $mode_trg if $KeepMode; + } + return wantarray ? (1,0,0) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings +} + +sub rcopy { + if (-l $_[0] && $CopyLink) { + goto &fcopy; + } + + goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*'; + goto &fcopy; +} + +sub rcopy_glob { + $glob->(\&rcopy, @_); +} + +sub dircopy { + if($RMTrgDir && -d $_[1]) { + if($RMTrgDir == 1) { + pathrmdir($_[1]) or carp "\$RMTrgDir failed: $!"; + } else { + pathrmdir($_[1]) or return; + } + } + my $globstar = 0; + my $_zero = $_[0]; + my $_one = $_[1]; + if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*') { + $globstar = 1; + $_zero = substr( $_zero, 0, ( length( $_zero ) - 1 ) ); + } + + $samecheck->( $_zero, $_[1] ) or return; + if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) { + $! = 20; + return; + } + + if(!-d $_[1]) { + pathmk($_[1], $NoFtlPth) or return; + } else { + if($CPRFComp && !$globstar) { + my @parts = File::Spec->splitdir($_zero); + while($parts[ $#parts ] eq '') { pop @parts; } + $_one = File::Spec->catdir($_[1], $parts[$#parts]); + } + } + my $baseend = $_one; + my $level = 0; + my $filen = 0; + my $dirn = 0; + + my $recurs; #must be my()ed before sub {} since it calls itself + $recurs = sub { + my ($str,$end,$buf) = @_; + $filen++ if $end eq $baseend; + $dirn++ if $end eq $baseend; + + $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0'; + mkdir($end,$DirPerms) or return if !-d $end; + chmod scalar((stat($str))[2]), $end if $KeepMode; + if($MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth) { + return ($filen,$dirn,$level) if wantarray; + return $filen; + } + $level++; + + + my @files; + if ( $] < 5.006 ) { + opendir(STR_DH, $str) or return; + @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH)); + closedir STR_DH; + } + else { + opendir(my $str_dh, $str) or return; + @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh)); + closedir $str_dh; + } + + for my $file (@files) { + my ($file_ut) = $file =~ m{ (.*) }xms; + my $org = File::Spec->catfile($str, $file_ut); + my $new = File::Spec->catfile($end, $file_ut); + if( -l $org && $CopyLink ) { + carp "Copying a symlink ($org) whose target does not exist" + if !-e readlink($org) && $BdTrgWrn; + symlink readlink($org), $new or return; + } + elsif(-d $org) { + $recurs->($org,$new,$buf) if defined $buf; + $recurs->($org,$new) if !defined $buf; + $filen++; + $dirn++; + } + else { + if($ok_todo_asper_condcopy->($org)) { + if($SkipFlop) { + fcopy($org,$new,$buf) or next if defined $buf; + fcopy($org,$new) or next if !defined $buf; + } + else { + fcopy($org,$new,$buf) or return if defined $buf; + fcopy($org,$new) or return if !defined $buf; + } + chmod scalar((stat($org))[2]), $new if $KeepMode; + $filen++; + } + } + } + 1; + }; + + $recurs->($_zero, $_one, $_[2]) or return; + return wantarray ? ($filen,$dirn,$level) : $filen; +} + +sub fmove { $move->(1, @_) } + +sub rmove { + if (-l $_[0] && $CopyLink) { + goto &fmove; + } + + goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1), 1) eq '*'; + goto &fmove; +} + +sub rmove_glob { + $glob->(\&rmove, @_); +} + +sub dirmove { $move->(0, @_) } + +sub pathmk { + my @parts = File::Spec->splitdir( shift() ); + my $nofatal = shift; + my $pth = $parts[0]; + my $zer = 0; + if(!$pth) { + $pth = File::Spec->catdir($parts[0],$parts[1]); + $zer = 1; + } + for($zer..$#parts) { + $DirPerms = oct($DirPerms) if substr($DirPerms,0,1) eq '0'; + mkdir($pth,$DirPerms) or return if !-d $pth && !$nofatal; + mkdir($pth,$DirPerms) if !-d $pth && $nofatal; + $pth = File::Spec->catdir($pth, $parts[$_ + 1]) unless $_ == $#parts; + } + 1; +} + +sub pathempty { + my $pth = shift; + + return 2 if !-d $pth; + + my @names; + my $pth_dh; + if ( $] < 5.006 ) { + opendir(PTH_DH, $pth) or return; + @names = grep !/^\.+$/, readdir(PTH_DH); + } + else { + opendir($pth_dh, $pth) or return; + @names = grep !/^\.+$/, readdir($pth_dh); + } + + for my $name (@names) { + my ($name_ut) = $name =~ m{ (.*) }xms; + my $flpth = File::Spec->catdir($pth, $name_ut); + + if( -l $flpth ) { + unlink $flpth or return; + } + elsif(-d $flpth) { + pathrmdir($flpth) or return; + } + else { + unlink $flpth or return; + } + } + + if ( $] < 5.006 ) { + closedir PTH_DH; + } + else { + closedir $pth_dh; + } + + 1; +} + +sub pathrm { + my $path = shift; + return 2 if !-d $path; + my @pth = File::Spec->splitdir( $path ); + my $force = shift; + + while(@pth) { + my $cur = File::Spec->catdir(@pth); + last if !$cur; # necessary ??? + if(!shift()) { + pathempty($cur) or return if $force; + rmdir $cur or return; + } + else { + pathempty($cur) if $force; + rmdir $cur; + } + pop @pth; + } + 1; +} + +sub pathrmdir { + my $dir = shift; + if( -e $dir ) { + return if !-d $dir; + } + else { + return 2; + } + + pathempty($dir) or return; + + rmdir $dir or return; +} + +1; + +__END__ + +=head1 NAME + +File::Copy::Recursive - Perl extension for recursively copying files and directories + +=head1 SYNOPSIS + + use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove); + + fcopy($orig,$new[,$buf]) or die $!; + rcopy($orig,$new[,$buf]) or die $!; + dircopy($orig,$new[,$buf]) or die $!; + + fmove($orig,$new[,$buf]) or die $!; + rmove($orig,$new[,$buf]) or die $!; + dirmove($orig,$new[,$buf]) or die $!; + + rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!; + rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!; + +=head1 DESCRIPTION + +This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode. + +=head1 EXPORT + +None by default. But you can export all the functions as in the example above and the path* functions if you wish. + +=head2 fcopy() + +This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be. +One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below) +The optional $buf in the synopsis if the same as File::Copy::copy()'s 3rd argument +returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomidate rcopy()'s list context on regular files. (See below for more info) + +=head2 dircopy() + +This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory. +$new is created if necessary (multiple non existant directories is ok (IE foo/bar/baz). The script logically and portably creates all of them if necessary). +It attempts to preserve the mode (see Preserving Mode below) and +by default it copies all the way down into the directory, (see Managing Depth) below. +If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified. + +returns true or false, for true in scalar context it returns the number of files and directories copied, +In list context it returns the number of files and directories, number of directories only, depth level traversed. + + my $num_of_files_and_dirs = dircopy($orig,$new); + my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new); + +Normally it stops and return's if a copy fails, to continue on regardless set $File::Copy::Recursive::SkipFlop to true. + + local $File::Copy::Recursive::SkipFlop = 1; + +That way it will copy everythgingit can ina directory and won't stop because of permissions, etc... + +=head2 rcopy() + +This function will allow you to specify a file *or* directory. It calls fcopy() if its a file and dircopy() if its a directory. +If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used. +This is important becasue if its a directory in list context and there is only the initial directory the return value is 1,1,1. + +=head2 rcopy_glob() + +This function lets you specify a pattern suitable for perl's glob() as the first argument. Subsequently each path returned by perl's glob() gets rcopy()ied. + +It returns and array whose items are array refs that contain the return value of each rcopy() call. + +It forces behavior as if $File::Copy::Recursive::CPRFComp is true. + +=head2 fmove() + +Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase. + +=head2 dirmove() + +Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase. + +=head2 rmove() + +Like rcopy() but calls fmove() or dirmove() instead. + +=head2 rmove_glob() + +Like rcopy_glob() but calls rmove() instead of rcopy() + +=head3 $RemvBase + +Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in. + +So if you: + + rmove('foo/bar/baz', '/etc/'); + # "baz" is removed from foo/bar after it is successfully copied to /etc/ + + local $File::Copy::Recursive::Remvbase = 1; + rmove('foo/bar/baz','/etc/'); + # if baz is successfully copied to /etc/ : + # first "baz" is removed from foo/bar + # then "foo/bar is removed via pathrm() + +=head4 $ForcePth + +Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect. + +=head2 Creating and Removing Paths + +=head3 $NoFtlPth + +Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure. + +If its set to true they just silently go about their business regardless. This isn't a good idea but its there if you want it. + +=head3 $DirPerms + +Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you. + +Any value you set it to should be suitable for oct() + +=head3 Path functions + +These functions exist soley because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move funtions work and use them by themselves if you wish. + +=head4 pathrm() + +Removes a given path recursively. It removes the *entire* path so be carefull!!! + +Returns 2 if the given path is not a directory. + + File::Copy::Recursive::pathrm('foo/bar/baz') or die $!; + # foo no longer exists + +Same as: + + rmdir 'foo/bar/baz' or die $!; + rmdir 'foo/bar' or die $!; + rmdir 'foo' or die $!; + +An optional second argument makes it call pathempty() before any rmdir()'s when set to true. + + File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!; + # foo no longer exists + +Same as:PFSCheck + + File::Copy::Recursive::pathempty('foo/bar/baz') or die $!; + rmdir 'foo/bar/baz' or die $!; + File::Copy::Recursive::pathempty('foo/bar/') or die $!; + rmdir 'foo/bar' or die $!; + File::Copy::Recursive::pathempty('foo/') or die $!; + rmdir 'foo' or die $!; + +An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea. + +=head4 pathempty() + +Recursively removes the given directory's contents so it is empty. returns 2 if argument is not a directory, 1 on successfully emptying the directory. + + File::Copy::Recursive::pathempty($pth) or die $!; + # $pth is now an empty directory + +=head4 pathmk() + +Creates a given path recursively. Creates foo/bar/baz even if foo does not exist. + + File::Copy::Recursive::pathmk('foo/bar/baz') or die $!; + +An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea. + +=head4 pathrmdir() + +Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents. +Just removes the top directory the path given instead of the entire path like pathrm(). Return 2 if given argument does not exist (IE its already gone). Return false if it exists but is not a directory. + +=head2 Preserving Mode + +By default a quiet attempt is made to change the new file or directory to the mode of the old one. +To turn this behavior off set + $File::Copy::Recursive::KeepMode +to false; + +=head2 Managing Depth + +You can set the maximum depth a directory structure is recursed by setting: + $File::Copy::Recursive::MaxDepth +to a whole number greater than 0. + +=head2 SymLinks + +If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file. +Perl's symlink() is used instead of File::Copy's copy() +You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value. +It is already set to true or false dending on your system's support of symlinks so you can check it with an if statement to see how it will behave: + + if($File::Copy::Recursive::CopyLink) { + print "Symlinks will be preserved\n"; + } else { + print "Symlinks will not be preserved because your system does not support it\n"; + } + +If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. Its false by default. + + local $File::Copy::Recursive::BdTrgWrn = 1; + +=head2 Removing existing target file or directory before copying. + +This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively. + +0 = off (This is the default) + +1 = carp() $! if removal fails + +2 = return if removal fails + + local $File::Copy::Recursive::RMTrgFil = 1; + fcopy($orig, $target) or die $!; + # if it fails it does warn() and keeps going + + local $File::Copy::Recursive::RMTrgDir = 2; + dircopy($orig, $target) or die $!; + # if it fails it does your "or die" + +This should be unnecessary most of the time but its there if you need it :) + +=head2 Turning off stat() check + +By default the files or directories are checked to see if they are the same (IE linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info. +It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System") + +=head2 Emulating cp -rf dir1/ dir2/ + +By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not. + +You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true. + +NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists. +If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above. + +That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf. +If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf) + +So assuming 'foo/file': + + dircopy('foo', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + + $File::Copy::Recursive::CPRFComp = 1; + dircopy('foo', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/foo/file + +You can also specify a star for cp -rf glob type behavior: + + dircopy('foo/*', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + + $File::Copy::Recursive::CPRFComp = 1; + dircopy('foo/*', 'bar') or die $!; + # if bar does not exist the result is bar/file + # if bar does exist the result is bar/file + +NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (IE not like cp -rf fo* to copy foo/*) + +=head2 Allowing Copy Loops + +If you want to allow: + + cp -rf . foo/ + +type behavior set $File::Copy::Recursive::CopyLoop to true. + +This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem. + +If you ever find a situation where $CopyLoop = 1 is desirable let me know (IE its a bad bad idea but is there if you want it) + +(Note: On Windows this was necessary since it uses stat() to detemine samedness and stat() is essencially useless for this on Windows. +The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share) + +=head1 SEE ALSO + +L L + +=head1 TO DO + +I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests. + +Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive. + +The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface. + +I'll add this after the latest verision has been out for a while with no new features or issues found :) + +=head1 AUTHOR + +Daniel Muey, L + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Daniel Muey + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Agent-Windows/Frontier/Client.pm b/Agent-Windows/Frontier/Client.pm new file mode 100644 index 00000000..0a9ac747 --- /dev/null +++ b/Agent-Windows/Frontier/Client.pm @@ -0,0 +1,285 @@ +# +# Copyright (C) 1998 Ken MacLeod +# Frontier::Client is free software; you can redistribute it +# and/or modify it under the same terms as Perl itself. +# +# $Id: Client.pm,v 1.8 2001/10/03 01:30:54 kmacleod Exp $ +# + +# NOTE: see Net::pRPC for a Perl RPC implementation + +use strict; + +package Frontier::Client; +use Frontier::RPC2; +use LWP::UserAgent; +use HTTP::Request; + +use vars qw{$AUTOLOAD}; + +sub new { + my $class = shift; + my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ }; + + bless $self, $class; + + die "Frontier::RPC::new: no url defined\n" + if !defined $self->{'url'}; + + $self->{'ua'} = LWP::UserAgent->new; + $self->{'ua'}->proxy('http', $self->{'proxy'}) + if(defined $self->{'proxy'}); + $self->{'rq'} = HTTP::Request->new (POST => $self->{'url'}); + $self->{'rq'}->header('Content-Type' => 'text/xml'); + + my @options; + + if(defined $self->{'encoding'}) { + push @options, 'encoding' => $self->{'encoding'}; + } + + if (defined $self->{'use_objects'} && $self->{'use_objects'}) { + push @options, 'use_objects' => $self->{'use_objects'}; + } + + $self->{'enc'} = Frontier::RPC2->new(@options); + + return $self; +} + +sub call { + my $self = shift; + + my $text = $self->{'enc'}->encode_call(@_); + + if ($self->{'debug'}) { + print "---- request ----\n"; + print $text; + } + + $self->{'rq'}->content($text); + + my $response = $self->{'ua'}->request($self->{'rq'}); + + if (!$response->is_success) { + die $response->status_line . "\n"; + } + + my $content = $response->content; + + if ($self->{'debug'}) { + print "---- response ----\n"; + print $content; + } + + my $result = $self->{'enc'}->decode($content); + + if ($result->{'type'} eq 'fault') { + die "Fault returned from XML RPC Server, fault code " . $result->{'value'}[0]{'faultCode'} . ": " + . $result->{'value'}[0]{'faultString'} . "\n"; + } + + return $result->{'value'}[0]; +} + +# shortcuts +sub base64 { + my $self = shift; + + return Frontier::RPC2::Base64->new(@_); +} + +sub boolean { + my $self = shift; + + return Frontier::RPC2::Boolean->new(@_); +} + +sub double { + my $self = shift; + + return Frontier::RPC2::Double->new(@_); +} + +sub int { + my $self = shift; + + return Frontier::RPC2::Integer->new(@_); +} + +sub string { + my $self = shift; + + return Frontier::RPC2::String->new(@_); +} + +sub date_time { + my $self = shift; + + return Frontier::RPC2::DateTime::ISO8601->new(@_); +} + +# something like this could be used to get an effect of +# +# $server->examples_getStateName(41) +# +# instead of +# +# $server->call('examples.getStateName', 41) +# +# for Frontier's +# +# [server].examples.getStateName 41 +# +# sub AUTOLOAD { +# my ($pkg, $method) = ($AUTOLOAD =~ m/^(.*::)(.*)$/); +# return if $method eq 'DESTROY'; +# +# $method =~ s/__/=/g; +# $method =~ tr/_=/._/; +# +# splice(@_, 1, 0, $method); +# +# goto &call; +# } + +=head1 NAME + +Frontier::Client - issue Frontier XML RPC requests to a server + +=head1 SYNOPSIS + + use Frontier::Client; + + $server = Frontier::Client->new( I ); + + $result = $server->call($method, @args); + + $boolean = $server->boolean($value); + $date_time = $server->date_time($value); + $base64 = $server->base64($value); + + $value = $boolean->value; + $value = $date_time->value; + $value = $base64->value; + +=head1 DESCRIPTION + +I is an XML-RPC client over HTTP. +I instances are used to make calls to XML-RPC +servers and as shortcuts for creating XML-RPC special data types. + +=head1 METHODS + +=over 4 + +=item new( I ) + +Returns a new instance of I and associates it with +an XML-RPC server at a URL. I may be a list of key, value +pairs or a hash containing the following parameters: + +=over 4 + +=item url + +The URL of the server. This parameter is required. For example: + + $server = Frontier::Client->new( 'url' => 'http://betty.userland.com/RPC2' ); + +=item proxy + +A URL of a proxy to forward XML-RPC calls through. + +=item encoding + +The XML encoding to be specified in the XML declaration of outgoing +RPC requests. Incoming results may have a different encoding +specified; XML::Parser will convert incoming data to UTF-8. The +default outgoing encoding is none, which uses XML 1.0's default of +UTF-8. For example: + + $server = Frontier::Client->new( 'url' => 'http://betty.userland.com/RPC2', + 'encoding' => 'ISO-8859-1' ); + +=item use_objects + +If set to a non-zero value will convert incoming Ei4E, +EfloatE, and EstringE values to objects instead of +scalars. See int(), float(), and string() below for more details. + +=item debug + +If set to a non-zero value will print the encoded XML request and the +XML response received. + +=back + +=item call($method, @args) + +Forward a procedure call to the server, either returning the value +returned by the procedure or failing with exception. `C<$method>' is +the name of the server method, and `C<@args>' is a list of arguments +to pass. Arguments may be Perl hashes, arrays, scalar values, or the +XML-RPC special data types below. + +=item boolean( $value ) + +=item date_time( $value ) + +=item base64( $base64 ) + +The methods `C', `C', and `C' create +and return XML-RPC-specific datatypes that can be passed to +`C'. Results from servers may also contain these datatypes. +The corresponding package names (for use with `C', for example) +are `C', +`C', and +`C'. + +The value of boolean, date/time, and base64 data can be set or +returned using the `C' method. For example: + + # To set a value: + $a_boolean->value(1); + + # To retrieve a value + $base64 = $base64_xml_rpc_data->value(); + +Note: `C' does I encode or decode base64 data for you, +you must use MIME::Base64 or similar module for that. + +=item int( 42 ); + +=item float( 3.14159 ); + +=item string( "Foo" ); + +By default, you may pass ordinary Perl values (scalars) to be encoded. +RPC2 automatically converts them to XML-RPC types if they look like an +integer, float, or as a string. This assumption causes problems when +you want to pass a string that looks like "0096", RPC2 will convert +that to an Ei4E because it looks like an integer. With these +methods, you could now create a string object like this: + + $part_num = $server->string("0096"); + +and be confident that it will be passed as an XML-RPC string. You can +change and retrieve values from objects using value() as described +above. + +=back + +=head1 SEE ALSO + +perl(1), Frontier::RPC2(3) + + + +=head1 AUTHOR + +Ken MacLeod + +=cut + +1; diff --git a/Agent-Windows/Frontier/Daemon.pm b/Agent-Windows/Frontier/Daemon.pm new file mode 100644 index 00000000..4891687e --- /dev/null +++ b/Agent-Windows/Frontier/Daemon.pm @@ -0,0 +1,96 @@ +# +# Copyright (C) 1998 Ken MacLeod +# Frontier::Daemon is free software; you can redistribute it +# and/or modify it under the same terms as Perl itself. +# +# $Id: Daemon.pm,v 1.5 2001/10/03 01:30:54 kmacleod Exp $ +# + +# NOTE: see Net::pRPC for a Perl RPC implementation + +### +### NOTE: $self is inherited from HTTP::Daemon and the weird access +### comes from there (`${*$self}'). +### + +use strict; + +package Frontier::Daemon; +use vars qw{@ISA}; + +@ISA = qw{HTTP::Daemon}; + +use Frontier::RPC2; +use HTTP::Daemon; +use HTTP::Status; + +sub new { + my $class = shift; my %args = @_; + my $self = $class->SUPER::new(%args); + return undef unless $self; + + ${*$self}{'methods'} = $args{'methods'}; + ${*$self}{'decode'} = new Frontier::RPC2 'use_objects' => $args{'use_objects'}; + ${*$self}{'response'} = new HTTP::Response 200; + ${*$self}{'response'}->header('Content-Type' => 'text/xml'); + + my $conn; + while ($conn = $self->accept) { + my $rq = $conn->get_request; + if ($rq) { + if ($rq->method eq 'POST' && $rq->url->path eq '/RPC2') { + ${*$self}{'response'}->content(${*$self}{'decode'}->serve($rq->content, ${*$self}{'methods'})); + $conn->send_response(${*$self}{'response'}); + } else { + $conn->send_error(RC_FORBIDDEN); + } + } + $conn->close; + $conn = undef; # close connection + } + + return $self; +} + +=head1 NAME + +Frontier::Daemon - receive Frontier XML RPC requests + +=head1 SYNOPSIS + + use Frontier::Daemon; + + Frontier::Daemon->new(methods => { + 'rpcName' => \&sub_name, + ... + }); + +=head1 DESCRIPTION + +I is an HTTP/1.1 server that listens on a socket for +incoming requests containing Frontier XML RPC2 method calls. +I is a subclass of I, which is a +subclass of I. + +I takes a `C' parameter, a hash that maps +an incoming RPC method name to reference to a subroutine. + +I takes a `C' parameter that if set to +a non-zero value will convert incoming EintE, Ei4E, +EfloatE, and EstringE values to objects instead of +scalars. See int(), float(), and string() in Frontier::RPC2 for more +details. + +=head1 SEE ALSO + +perl(1), HTTP::Daemon(3), IO::Socket::INET(3), Frontier::RPC2(3) + + + +=head1 AUTHOR + +Ken MacLeod + +=cut + +1; diff --git a/Agent-Windows/Frontier/Daemon/OGP/Forking.pm b/Agent-Windows/Frontier/Daemon/OGP/Forking.pm new file mode 100644 index 00000000..49fa3153 --- /dev/null +++ b/Agent-Windows/Frontier/Daemon/OGP/Forking.pm @@ -0,0 +1,95 @@ +package Frontier::Daemon::OGP::Forking; +# $Id: Forking.pm,v 1.6 2004/01/23 19:48:33 tcaine Exp $ + +use strict; +use vars qw{@ISA $VERSION}; + +$VERSION = '0.02'; + +use Frontier::RPC2; +use HTTP::Daemon; +use HTTP::Status; + +@ISA = qw{HTTP::Daemon}; + +# most of this routine comes directly from Frontier::Daemon +sub new { + my $class = shift; + my %args = @_; + my $encoding = delete $args{encoding}; + my $self = $class->SUPER::new( %args ); + return undef unless $self; + + my @options; + push @options, encoding => $encoding + if $encoding; + + ${*$self}{methods} = $args{methods}; + ${*$self}{decode} = new Frontier::RPC2(@options); + ${*$self}{response} = new HTTP::Response 200; + ${*$self}{response}->header( 'Content-Type' => 'text/xml' ); + + local $SIG{CHLD} = 'IGNORE'; + +ACCEPT: + while ( my $conn = $self->accept ) { + my $pid = fork; + next ACCEPT if $pid; + + if ( not defined $pid ) { + warn "fork() failed: $!"; + $conn = undef; + } + else { + my $request = $conn->get_request; + if ($request) { + if ($request->method eq 'POST' && $request->url->path eq '/RPC2') { + ${*$self}{'response'}->content( + ${*$self}{'decode'}->serve( + $request->content, + ${*$self}{'methods'}, + ) + ); + $conn->send_response(${*$self}{'response'}); + } else { + $conn->send_error(RC_FORBIDDEN); + } + } + } + exit; + } +} + +1; +__END__ + +=head1 NAME + +Frontier::Daemon::Forking - receive Frontier XML RPC requests + +=head1 SYNOPSIS + + use Frontier::Daemon::Forking; + + Frontier::Daemon::Forking->new( + methods => { + rpcName => \&rpcHandler, + }, + encoding => 'ISO-8859-1', + ); + + sub rpcHandler { return 'OK' } + +=head1 DESCRIPTION + +L is a drop in replacement for L when a forking HTTP/1.1 server is needed that listens on a socket for incoming requests containing Frontier XML RPC2 method calls. Most of the code was borrowed from L. + +=head1 AUTHOR + +Todd Caine, tcaine@pobox.com + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/Agent-Windows/Frontier/RPC2.pm b/Agent-Windows/Frontier/RPC2.pm new file mode 100644 index 00000000..a42ec4dd --- /dev/null +++ b/Agent-Windows/Frontier/RPC2.pm @@ -0,0 +1,701 @@ +# +# Copyright (C) 1998, 1999 Ken MacLeod +# Frontier::RPC is free software; you can redistribute it +# and/or modify it under the same terms as Perl itself. +# +# $Id: RPC2.pm,v 1.18 2002/08/02 18:35:21 ivan420 Exp $ +# + +# NOTE: see Storable for marshalling. + +use strict; + +package Frontier::RPC2; +use XML::Parser; + +use vars qw{%scalars %char_entities}; + +%char_entities = ( + '&' => '&', + '<' => '<', + '>' => '>', + '"' => '"', +); + +# FIXME I need a list of these +%scalars = ( + 'base64' => 1, + 'boolean' => 1, + 'dateTime.iso8601' => 1, + 'double' => 1, + 'int' => 1, + 'i4' => 1, + 'string' => 1, +); + +sub new { + my $class = shift; + my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ }; + + bless $self, $class; + + if (defined $self->{'encoding'}) { + $self->{'encoding_'} = " encoding=\"$self->{'encoding'}\""; + } else { + $self->{'encoding_'} = ""; + } + + return $self; +} + +sub encode_call { + my $self = shift; my $proc = shift; + + my @text; + push @text, <{'encoding_'}?> + +$proc + +EOF + + push @text, $self->_params([@_]); + + push @text, < + +EOF + + return join('', @text); +} + +sub encode_response { + my $self = shift; + + my @text; + push @text, <{'encoding_'}?> + + +EOF + + push @text, $self->_params([@_]); + + push @text, < + +EOF + + return join('', @text); +} + +sub encode_fault { + my $self = shift; my $code = shift; my $message = shift; + + my @text; + push @text, <{'encoding_'}?> + + +EOF + + push @text, $self->_item({faultCode => $code, faultString => $message}); + + push @text, < + +EOF + + return join('', @text); +} + +sub serve { + my $self = shift; my $xml = shift; my $methods = shift; + + my $call; + # FIXME bug in Frontier's XML + $xml =~ s/(<\?XML\s+VERSION)/\L$1\E/; + eval { $call = $self->decode($xml) }; + + if ($@) { + return $self->encode_fault(1, "error decoding RPC.\n" . $@); + } + + if ($call->{'type'} ne 'call') { + return $self->encode_fault(2,"expected RPC \`methodCall', got \`$call->{'type'}'\n"); + } + + my $method = $call->{'method_name'}; + if (!defined $methods->{$method}) { + return $self->encode_fault(3, "no such method \`$method'\n"); + } + + my $result; + my $eval = eval { $result = &{ $methods->{$method} }(@{ $call->{'value'} }) }; + if ($@) { + return $self->encode_fault(4, "error executing RPC \`$method'.\n" . $@); + } + + my $response_xml = $self->encode_response($result); + return $response_xml; +} + +sub _params { + my $self = shift; my $array = shift; + + my @text; + + my $item; + foreach $item (@$array) { + push (@text, "", + $self->_item($item), + "\n"); + } + + return @text; +} + +sub _item { + my $self = shift; my $item = shift; + + my @text; + + my $ref = ref($item); + if (!$ref) { + push (@text, $self->_scalar ($item)); + } elsif ($ref eq 'ARRAY') { + push (@text, $self->_array($item)); + } elsif ($ref eq 'HASH') { + push (@text, $self->_hash($item)); + } elsif ($ref eq 'Frontier::RPC2::Boolean') { + push @text, "", $item->repr, "\n"; + } elsif ($ref eq 'Frontier::RPC2::String') { + push @text, "", $item->repr, "\n"; + } elsif ($ref eq 'Frontier::RPC2::Integer') { + push @text, "", $item->repr, "\n"; + } elsif ($ref eq 'Frontier::RPC2::Double') { + push @text, "", $item->repr, "\n"; + } elsif ($ref eq 'Frontier::RPC2::DateTime::ISO8601') { + push @text, "", $item->repr, "\n"; + } elsif ($ref eq 'Frontier::RPC2::Base64') { + push @text, "", $item->repr, "\n"; + } elsif ($ref =~ /=HASH\(/) { + push @text, $self->_hash($item); + } elsif ($ref =~ /=ARRAY\(/) { + push @text, $self->_array($item); + } else { + die "can't convert \`$item' to XML\n"; + } + + return @text; +} + +sub _hash { + my $self = shift; my $hash = shift; + + my @text = "\n"; + + my ($key, $value); + while (($key, $value) = each %$hash) { + push (@text, + "$key", + $self->_item($value), + "\n"); + } + + push @text, "\n"; + + return @text; +} + + +sub _array { + my $self = shift; my $array = shift; + + my @text = "\n"; + + my $item; + foreach $item (@$array) { + push @text, $self->_item($item); + } + + push @text, "\n"; + + return @text; +} + +sub _scalar { + my $self = shift; my $value = shift; + + # these are from `perldata(1)' + if ($value =~ /^[+-]?\d+$/) { + return ("$value"); + } elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/) { + return ("$value"); + } else { + $value =~ s/([&<>\"])/$char_entities{$1}/ge; + return ("$value"); + } +} + +sub decode { + my $self = shift; my $string = shift; + + $self->{'parser'} = XML::Parser->new( Style => ref($self), + 'use_objects' => $self->{'use_objects'} ); + return $self->{'parser'}->parsestring($string); +} + +# shortcuts +sub base64 { + my $self = shift; + + return Frontier::RPC2::Base64->new(@_); +} + +sub boolean { + my $self = shift; + my $elem = shift; + if($elem == 0 or $elem == 1) { + return Frontier::RPC2::Boolean->new($elem); + } else { + die "error in rendering RPC type \`$elem\' not a boolean\n"; + } +} + +sub double { + my $self = shift; + my $elem = shift; + # this is from `perldata(1)' + if($elem =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) { + return Frontier::RPC2::Double->new($elem); + } else { + die "error in rendering RPC type \`$elem\' not a double\n"; + } +} + +sub int { + my $self = shift; + my $elem = shift; + # this is from `perldata(1)' + if($elem =~ /^[+-]?\d+$/) { + return Frontier::RPC2::Integer->new($elem); + } else { + die "error in rendering RPC type \`$elem\' not an int\n"; + } +} + +sub string { + my $self = shift; + + return Frontier::RPC2::String->new(@_); +} + +sub date_time { + my $self = shift; + + return Frontier::RPC2::DateTime::ISO8601->new(@_); +} + +###################################################################### +### +### XML::Parser callbacks +### + +sub die { + my $expat = shift; my $message = shift; + + die $message + . "at line " . $expat->current_line + . " column " . $expat->current_column . "\n"; +} + +sub init { + my $expat = shift; + + $expat->{'rpc_state'} = []; + $expat->{'rpc_container'} = [ [] ]; + $expat->{'rpc_member_name'} = []; + $expat->{'rpc_type'} = undef; + $expat->{'rpc_args'} = undef; +} + +# FIXME this state machine wouldn't be necessary if we had a DTD. +sub start { + my $expat = shift; my $tag = shift; + + my $state = $expat->{'rpc_state'}[-1]; + + if (!defined $state) { + if ($tag eq 'methodCall') { + $expat->{'rpc_type'} = 'call'; + push @{ $expat->{'rpc_state'} }, 'want_method_name'; + } elsif ($tag eq 'methodResponse') { + push @{ $expat->{'rpc_state'} }, 'method_response'; + } else { + Frontier::RPC2::die($expat, "unknown RPC type \`$tag'\n"); + } + } elsif ($state eq 'want_method_name') { + Frontier::RPC2::die($expat, "wanted \`methodName' tag, got \`$tag'\n") + if ($tag ne 'methodName'); + push @{ $expat->{'rpc_state'} }, 'method_name'; + $expat->{'rpc_text'} = ""; + } elsif ($state eq 'method_response') { + if ($tag eq 'params') { + $expat->{'rpc_type'} = 'response'; + push @{ $expat->{'rpc_state'} }, 'params'; + } elsif ($tag eq 'fault') { + $expat->{'rpc_type'} = 'fault'; + push @{ $expat->{'rpc_state'} }, 'want_value'; + } + } elsif ($state eq 'want_params') { + Frontier::RPC2::die($expat, "wanted \`params' tag, got \`$tag'\n") + if ($tag ne 'params'); + push @{ $expat->{'rpc_state'} }, 'params'; + } elsif ($state eq 'params') { + Frontier::RPC2::die($expat, "wanted \`param' tag, got \`$tag'\n") + if ($tag ne 'param'); + push @{ $expat->{'rpc_state'} }, 'want_param_name_or_value'; + } elsif ($state eq 'want_param_name_or_value') { + if ($tag eq 'value') { + $expat->{'may_get_cdata'} = 1; + $expat->{'rpc_text'} = ""; + push @{ $expat->{'rpc_state'} }, 'value'; + } elsif ($tag eq 'name') { + push @{ $expat->{'rpc_state'} }, 'param_name'; + } else { + Frontier::RPC2::die($expat, "wanted \`value' or \`name' tag, got \`$tag'\n"); + } + } elsif ($state eq 'param_name') { + Frontier::RPC2::die($expat, "wanted parameter name data, got tag \`$tag'\n"); + } elsif ($state eq 'want_value') { + Frontier::RPC2::die($expat, "wanted \`value' tag, got \`$tag'\n") + if ($tag ne 'value'); + $expat->{'rpc_text'} = ""; + $expat->{'may_get_cdata'} = 1; + push @{ $expat->{'rpc_state'} }, 'value'; + } elsif ($state eq 'value') { + $expat->{'may_get_cdata'} = 0; + if ($tag eq 'array') { + push @{ $expat->{'rpc_container'} }, []; + push @{ $expat->{'rpc_state'} }, 'want_data'; + } elsif ($tag eq 'struct') { + push @{ $expat->{'rpc_container'} }, {}; + push @{ $expat->{'rpc_member_name'} }, undef; + push @{ $expat->{'rpc_state'} }, 'struct'; + } elsif ($scalars{$tag}) { + $expat->{'rpc_text'} = ""; + push @{ $expat->{'rpc_state'} }, 'cdata'; + } else { + Frontier::RPC2::die($expat, "wanted a data type, got \`$tag'\n"); + } + } elsif ($state eq 'want_data') { + Frontier::RPC2::die($expat, "wanted \`data', got \`$tag'\n") + if ($tag ne 'data'); + push @{ $expat->{'rpc_state'} }, 'array'; + } elsif ($state eq 'array') { + Frontier::RPC2::die($expat, "wanted \`value' tag, got \`$tag'\n") + if ($tag ne 'value'); + $expat->{'rpc_text'} = ""; + $expat->{'may_get_cdata'} = 1; + push @{ $expat->{'rpc_state'} }, 'value'; + } elsif ($state eq 'struct') { + Frontier::RPC2::die($expat, "wanted \`member' tag, got \`$tag'\n") + if ($tag ne 'member'); + push @{ $expat->{'rpc_state'} }, 'want_member_name'; + } elsif ($state eq 'want_member_name') { + Frontier::RPC2::die($expat, "wanted \`name' tag, got \`$tag'\n") + if ($tag ne 'name'); + push @{ $expat->{'rpc_state'} }, 'member_name'; + $expat->{'rpc_text'} = ""; + } elsif ($state eq 'member_name') { + Frontier::RPC2::die($expat, "wanted data, got tag \`$tag'\n"); + } elsif ($state eq 'cdata') { + Frontier::RPC2::die($expat, "wanted data, got tag \`$tag'\n"); + } else { + Frontier::RPC2::die($expat, "internal error, unknown state \`$state'\n"); + } +} + +sub end { + my $expat = shift; my $tag = shift; + + my $state = pop @{ $expat->{'rpc_state'} }; + + if ($state eq 'cdata') { + my $value = $expat->{'rpc_text'}; + if ($tag eq 'base64') { + $value = Frontier::RPC2::Base64->new($value); + } elsif ($tag eq 'boolean') { + $value = Frontier::RPC2::Boolean->new($value); + } elsif ($tag eq 'dateTime.iso8601') { + $value = Frontier::RPC2::DateTime::ISO8601->new($value); + } elsif ($expat->{'use_objects'}) { + if ($tag eq 'i4' or $tag eq 'int') { + $value = Frontier::RPC2::Integer->new($value); + } elsif ($tag eq 'float') { + $value = Frontier::RPC2::Float->new($value); + } elsif ($tag eq 'string') { + $value = Frontier::RPC2::String->new($value); + } + } + $expat->{'rpc_value'} = $value; + } elsif ($state eq 'member_name') { + $expat->{'rpc_member_name'}[-1] = $expat->{'rpc_text'}; + $expat->{'rpc_state'}[-1] = 'want_value'; + } elsif ($state eq 'method_name') { + $expat->{'rpc_method_name'} = $expat->{'rpc_text'}; + $expat->{'rpc_state'}[-1] = 'want_params'; + } elsif ($state eq 'struct') { + $expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} }; + pop @{ $expat->{'rpc_member_name'} }; + } elsif ($state eq 'array') { + $expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} }; + } elsif ($state eq 'value') { + # the rpc_text is a string if no type tags were given + if ($expat->{'may_get_cdata'}) { + $expat->{'may_get_cdata'} = 0; + if ($expat->{'use_objects'}) { + $expat->{'rpc_value'} + = Frontier::RPC2::String->new($expat->{'rpc_text'}); + } else { + $expat->{'rpc_value'} = $expat->{'rpc_text'}; + } + } + my $container = $expat->{'rpc_container'}[-1]; + if (ref($container) eq 'ARRAY') { + push @$container, $expat->{'rpc_value'}; + } elsif (ref($container) eq 'HASH') { + $container->{ $expat->{'rpc_member_name'}[-1] } = $expat->{'rpc_value'}; + } + } +} + +sub char { + my $expat = shift; my $text = shift; + + $expat->{'rpc_text'} .= $text; +} + +sub proc { +} + +sub final { + my $expat = shift; + + $expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} }; + + return { + value => $expat->{'rpc_value'}, + type => $expat->{'rpc_type'}, + method_name => $expat->{'rpc_method_name'}, + }; +} + +package Frontier::RPC2::DataType; + +sub new { + my $type = shift; my $value = shift; + + return bless \$value, $type; +} + +# `repr' returns the XML representation of this data, which may be +# different [in the future] from what is returned from `value' +sub repr { + my $self = shift; + + return $$self; +} + +# sets or returns the usable value of this data +sub value { + my $self = shift; + @_ ? ($$self = shift) : $$self; +} + +package Frontier::RPC2::Base64; + +use vars qw{@ISA}; +@ISA = qw{Frontier::RPC2::DataType}; + +package Frontier::RPC2::Boolean; + +use vars qw{@ISA}; +@ISA = qw{Frontier::RPC2::DataType}; + +package Frontier::RPC2::Integer; + +use vars qw{@ISA}; +@ISA = qw{Frontier::RPC2::DataType}; + +package Frontier::RPC2::String; + +use vars qw{@ISA}; +@ISA = qw{Frontier::RPC2::DataType}; + +sub repr { + my $self = shift; + my $value = $$self; + $value =~ s/([&<>\"])/$Frontier::RPC2::char_entities{$1}/ge; + $value; +} + +package Frontier::RPC2::Double; + +use vars qw{@ISA}; +@ISA = qw{Frontier::RPC2::DataType}; + +package Frontier::RPC2::DateTime::ISO8601; + +use vars qw{@ISA}; +@ISA = qw{Frontier::RPC2::DataType}; + +=head1 NAME + +Frontier::RPC2 - encode/decode RPC2 format XML + +=head1 SYNOPSIS + + use Frontier::RPC2; + + $coder = Frontier::RPC2->new; + + $xml_string = $coder->encode_call($method, @args); + $xml_string = $coder->encode_response($result); + $xml_string = $coder->encode_fault($code, $message); + + $call = $coder->decode($xml_string); + + $response_xml = $coder->serve($request_xml, $methods); + + $boolean_object = $coder->boolean($boolean); + $date_time_object = $coder->date_time($date_time); + $base64_object = $coder->base64($base64); + $int_object = $coder->int(42); + $float_object = $coder->float(3.14159); + $string_object = $coder->string("Foo"); + +=head1 DESCRIPTION + +I encodes and decodes XML RPC calls. + +=over 4 + +=item $coder = Frontier::RPC2->new( I ) + +Create a new encoder/decoder. The following option is supported: + +=over 4 + +=item encoding + +The XML encoding to be specified in the XML declaration of encoded RPC +requests or responses. Decoded results may have a different encoding +specified; XML::Parser will convert decoded data to UTF-8. The +default encoding is none, which uses XML 1.0's default of UTF-8. For +example: + + $server = Frontier::RPC2->new( 'encoding' => 'ISO-8859-1' ); + +=item use_objects + +If set to a non-zero value will convert incoming Ei4E, +EfloatE, and EstringE values to objects instead of +scalars. See int(), float(), and string() below for more details. + +=back + +=item $xml_string = $coder->encode_call($method, @args) + +`C' converts a method name and it's arguments into an +RPC2 `C' element, returning the XML fragment. + +=item $xml_string = $coder->encode_response($result) + +`C' converts the return value of a procedure into an +RPC2 `C' element containing the result, returning the +XML fragment. + +=item $xml_string = $coder->encode_fault($code, $message) + +`C' converts a fault code and message into an RPC2 +`C' element containing a `C' element, returning +the XML fragment. + +=item $call = $coder->decode($xml_string) + +`C' converts an XML string containing an RPC2 `C' +or `C' element into a hash containing three members, +`C', `C', and `C'. `C' is one of +`C', `C', or `C'. `C' is array +containing the parameters or result of the RPC. For a `C' type, +`C' contains call's parameters and `C' contains +the method being called. For a `C' type, the `C' +array contains call's result. For a `C' type, the `C' +array contains a hash with the two members `C' and +`C'. + +=item $response_xml = $coder->serve($request_xml, $methods) + +`C' decodes `C<$request_xml>', looks up the called method name +in the `C<$methods>' hash and calls it, and then encodes and returns +the response as XML. + +=item $boolean_object = $coder->boolean($boolean); + +=item $date_time_object = $coder->date_time($date_time); + +=item $base64_object = $coder->base64($base64); + +These methods create and return XML-RPC-specific datatypes that can be +passed to the encoder. The decoder may also return these datatypes. +The corresponding package names (for use with `C', for example) +are `C', +`C', and +`C'. + +You can change and retrieve the value of boolean, date/time, and +base64 data using the `C' method of those objects, i.e.: + + $boolean = $boolean_object->value; + + $boolean_object->value(1); + +Note: `C' does I encode or decode base64 data for you, +you must use MIME::Base64 or similar module for that. + +=item $int_object = $coder->int(42); + +=item $float_object = $coder->float(3.14159); + +=item $string_object = $coder->string("Foo"); + +By default, you may pass ordinary Perl values (scalars) to be encoded. +RPC2 automatically converts them to XML-RPC types if they look like an +integer, float, or as a string. This assumption causes problems when +you want to pass a string that looks like "0096", RPC2 will convert +that to an Ei4E because it looks like an integer. With these +methods, you could now create a string object like this: + + $part_num = $coder->string("0096"); + +and be confident that it will be passed as an XML-RPC string. You can +change and retrieve values from objects using value() as described +above. + +=back + +=head1 SEE ALSO + +perl(1), Frontier::Daemon(3), Frontier::Client(3) + + + +=head1 AUTHOR + +Ken MacLeod + +=cut + +1; diff --git a/Agent-Windows/Frontier/Responder.pm b/Agent-Windows/Frontier/Responder.pm new file mode 100644 index 00000000..d3ee5303 --- /dev/null +++ b/Agent-Windows/Frontier/Responder.pm @@ -0,0 +1,170 @@ +# File: Repsonder.pm +# based heavily on Ken MacLeod's Frontier::Daemon +# Author: Joe Johnston 7/2000 +# Revisions: +# 11/2000 - Cleaned/Add POD. Took out 'use CGI'. +# +# Meant to be called from a CGI process to answer client +# requests and emit the appropriate reponses. See POD for details. +# +# LICENSE: This code is released under the same licensing +# as Perl itself. +# +# Use the code where ever you want, but due credit is appreciated. + +package Frontier::Responder; + +use strict; +use vars qw/@ISA/; + +use Frontier::RPC2; + +my $snappy_answer = "Hey, I need to return true, don't I?"; + +# Class constructor. +# Input: (expects parameters to be passed in as a hash) +# methods => hashref, keys are API procedure names, values are +# subroutine references +# +# Output: blessed reference +sub new { + my $class = shift; + my %args = @_; + my $self = bless {}, (ref $class ? ref $class : $class); + + # Store the dispatch table away for future use. + $self->{methods} = $args{methods}; + $self->{_decode} = Frontier::RPC2->new(); + + return $self; +} + +# Grabs input from CGI "stream", makes request +# if possible, packs up the response in purddy +# XML +# Input: None +# Output: A XML string suitable for printing from a CGI process +sub answer{ + my $self = shift; + + # fetch the xml message sent + my $request = get_cgi_request(); + + unless( defined $request ){ + print + "Content-Type: text/txt\n\n"; + exit; + } + + # Let's figure out the method to execute + # along with its arguments + my $response = $self->{_decode}->serve( $request, + $self->{methods} ); + # Ship it! + return + "Content-Type: text/xml \n\n" . $response; + +} + +# private function. No need to advertise this. +# Remember, this is just XML. +# CGI.pm doesn't grok this. +sub get_cgi_request{ + my $in; + if( $ENV{REQUEST_METHOD} eq 'POST' ){ + my $len = $ENV{CONTENT_LENGTH}; + unless ( read( STDIN, $in, $len ) == $len ){ + return; + } + }else{ + $in = $ENV{QUERY_STRING}; + } + + return $in; +} + +=pod + +=head1 NAME + +Frontier::Responder - Create XML-RPC listeners for normal CGI processes + +=head1 SYNOPSIS + + use Frontier::Responder; + my $res = Frontier::Responder->new( methods => { + add => sub{ $_[0] + $_[1] }, + cat => sub{ $_[0] . $_[1] }, + }, + ); + print $res->answer; + +=head1 DESCRIPTION + +Use I whenever you need to create an XML-RPC listener +using a standard CGI interface. To be effective, a script using this class +will often have to be put a directory from which a web server is authorized +to execute CGI programs. An XML-RPC listener using this library will be +implementing the API of a particular XML-RPC application. Each remote +procedure listed in the API of the user defined application will correspond +to a hash key that is defined in the C method of a I +object. This is exactly the way I works as well. +In order to process the request and get the response, the C method +is needed. Its return value is XML ready for printing. + +For those new to XML-RPC, here is a brief description of this protocol. +XML-RPC is a way to execute functions on a different +machine. Both the client's request and listeners response are wrapped +up in XML and sent over HTTP. Because the XML-RPC conversation is in +XML, the implementation languages of the server (here called a I), +and the client can be different. This can be a powerful and simple way +to have very different platforms work together without acrimony. Implicit +in the use of XML-RPC is a contract or API that an XML-RPC listener +implements and an XML-RPC client calls. The API needs to list not only +the various procedures that can be called, but also the XML-RPC datatypes +expected for input and output. Remember that although Perl is permissive +about datatyping, other languages are not. Unforuntately, the XML-RPC spec +doesn't say how to document the API. It is recomended that the author +of a Perl XML-RPC listener should at least use POD to explain the API. +This allows for the programmatic generation of a clean web page. + +=head1 METHODS + +=over 4 + +=item new( I ) + +This is the class constructor. As is traditional, it returns +a blessed reference to a I object. It expects +arguments to be given like a hash (Perl's named parameter mechanism). +To be effective, populate the C parameter with a hashref +that has API procedure names as keys and subroutine references as +values. See the SYNOPSIS for a sample usage. + + +=item answer() + +In order to parse the request and execute the procedure, this method +must be called. It returns a XML string that contains the procedure's +response. In a typical CGI program, this string will simply be printed +to STDOUT. + + +=back + +=head1 SEE ALSO + +perl(1), Frontier::RPC2(3) + + + +=head1 AUTHOR + +Ken MacLeod wrote the underlying +RPC library. + +Joe Johnston wrote an adaptation +of the Frontier::Daemon class to create this CGI XML-RPC +listener class. + +=cut diff --git a/Agent-Windows/Install/Cygwin-Terminal.ico b/Agent-Windows/Install/Cygwin-Terminal.ico new file mode 100644 index 00000000..8690d542 Binary files /dev/null and b/Agent-Windows/Install/Cygwin-Terminal.ico differ diff --git a/Agent-Windows/Install/Cygwin.bat b/Agent-Windows/Install/Cygwin.bat new file mode 100644 index 00000000..f822a754 --- /dev/null +++ b/Agent-Windows/Install/Cygwin.bat @@ -0,0 +1,4 @@ +@echo off +setlocal enableextensions +set TERM= +cd /d "%~dp0bin" && .\bash --login -i diff --git a/Agent-Windows/Install/Cygwin.ico b/Agent-Windows/Install/Cygwin.ico new file mode 100644 index 00000000..8b6895de Binary files /dev/null and b/Agent-Windows/Install/Cygwin.ico differ diff --git a/Agent-Windows/Install/agent_start.bat b/Agent-Windows/Install/agent_start.bat new file mode 100644 index 00000000..d04a11d1 --- /dev/null +++ b/Agent-Windows/Install/agent_start.bat @@ -0,0 +1,41 @@ +@echo off +@title OGP Agent +FOR /f "tokens=2,3,4 delims=[.]" %%a IN ('ver') DO SET WVer=%%a +FOR /f "tokens=2,3 delims= " %%a IN ('echo %WVer%') DO SET Ver=%%a +whoami /groups | find "S-1-16-12288" >nul 2>&1 +if NOT %errorLevel% == 0 if %VER% GEQ 6 ( + echo Failure: Current permissions inadequate. + echo[ + echo Run this script by using "Run as administrator" in the context menu. + pause >nul + exit +) +set WD=%~dp0 +pushd %WD% +set path=%WD%bin;%WD%usr\sbin;%path% +set CYGWIN=server ntsec +set SHELL=/bin/bash +set runAgentNormally=no + +REM Stop any running agent +if exist %WD%var\run\pure-ftpd.pid set /p PID1=<%WD%var\run\pure-ftpd.pid +if exist %WD%OGP\ogp_agent.pid set /p PID2=<%WD%OGP\ogp_agent.pid +if exist %WD%OGP\ogp_agent_run.pid set /p PID3=<%WD%OGP\ogp_agent_run.pid +IF NOT [%PID1%] == [] kill -15 %PID1% +IF NOT [%PID2%] == [] kill -15 %PID2% +IF NOT [%PID3%] == [] kill -15 %PID3% + +REM Check for gameserver user and if it exists and the user running this script matches, run it the normal way, else prompt for elevation +if "%username%" == "" set runAgentNormally=yes +if "%username%" == "gameserver" set runAgentNormally=yes + +net user gameserver +if %ERRORLEVEL% EQU 0 ( + if %runAgentNormally% == yes ( + bash ogp_agent -pidfile /OGP/ogp_agent_run.pid + ) else ( + cygstart mintty /c "runas /profile /user:gameserver \"%WD%\bin\bash.exe %WD%\bin\ogp_agent -pidfile /OGP/ogp_agent_run.pid\"" + ) +) else ( + bash ogp_agent -pidfile /OGP/ogp_agent_run.pid +) diff --git a/Agent-Windows/Install/agent_stop.bat b/Agent-Windows/Install/agent_stop.bat new file mode 100644 index 00000000..7e8bcedc --- /dev/null +++ b/Agent-Windows/Install/agent_stop.bat @@ -0,0 +1,21 @@ +@echo off +@title Stop OGP Agent +net session >nul 2>&1 +if NOT %errorLevel% == 0 ( + echo Failure: Current permissions inadequate. + echo[ + echo Run this script by using "Run as administrator" in the context menu. + pause >nul + exit +) +set WD=%~dp0 +pushd %WD% +set path=%WD%bin;%WD%usr\sbin;%path% +set CYGWIN=server ntsec +set SHELL=/bin/bash +if exist %WD%var\run\pure-ftpd.pid set /p PID1=<%WD%var\run\pure-ftpd.pid +if exist %WD%OGP\ogp_agent.pid set /p PID2=<%WD%OGP\ogp_agent.pid +if exist %WD%OGP\ogp_agent_run.pid set /p PID3=<%WD%OGP\ogp_agent_run.pid +IF NOT [%PID1%] == [] kill -15 %PID1% +IF NOT [%PID2%] == [] kill -15 %PID2% +IF NOT [%PID3%] == [] kill -15 %PID3% diff --git a/Agent-Windows/Install/grant.exe b/Agent-Windows/Install/grant.exe new file mode 100644 index 00000000..55e32870 Binary files /dev/null and b/Agent-Windows/Install/grant.exe differ diff --git a/Agent-Windows/Install/install_apache.sh b/Agent-Windows/Install/install_apache.sh new file mode 100644 index 00000000..049bea39 --- /dev/null +++ b/Agent-Windows/Install/install_apache.sh @@ -0,0 +1,5 @@ +#!/bin/bash +# Installs Apache for Windows on Cygwin +/etc/rc.d/init.d/httpd install +cygrunsrv -S httpd +/etc/rc.d/init.d/httpd reload diff --git a/Agent-Windows/Install/onceinstall_agent.bat b/Agent-Windows/Install/onceinstall_agent.bat new file mode 100644 index 00000000..0f0bfde6 --- /dev/null +++ b/Agent-Windows/Install/onceinstall_agent.bat @@ -0,0 +1,107 @@ +@echo off +net session >nul 2>&1 +IF %ERRORLEVEL% neq 0 ( + echo Failure: Current permissions inadequate. + echo[ + echo Run this script by using "Run as administrator" in the context menu. + pause >nul + exit +) +REM Remove the trailing \ in the path or else Cygwin will flip when it's enclosed in double quotes (http://stackoverflow.com/questions/3160058/how-to-get-the-path-of-a-batch-script-without-the-trailing-backslash-in-a-single && https://cygwin.com/ml/cygwin/2016-11/msg00178.html) +set WD=%~dp0 +pushd %WD% +set WD=%WD:~0,-1% +REM Set the needed enviroment variables to run Cygwin executables without writing the full path +set CYGWIN=server ntsec +REM PATH CANNOT BE DOUBLE QUOTED (http://serverfault.com/questions/349179/path-variable-and-quotation-marks-windows) +set path=%WD%\bin;%WD%\usr\sbin;%path% +set SHELL=/bin/bash +REM Advice +echo DO NOT CLOSE THIS WINDOW YET. +echo The setup process will continue once cygwin installation ends. +REM Download latest Cygwin +tools\wget.exe -N "https://cygwin.com/setup-x86_64.exe" -O "setup-x86_64.exe" --no-check-certificate +REM start the setup for cygwin with the requiered repositories, paths and packages +REM OLD WAY: +REM setup-x86_64.exe --local-install --quiet-mode --root %WD% --local-package-dir %WD%cygTemp --packages "screen,perl,perl-HTTP-Daemon,perl-Path-Class,perl-XML-Parser,perl-Archive-Zip,perl-XML-Simple,wget,unzip,rsync,curl,bzip2,zip,cygrunsrv,dos2unix,mutt,ssmtp,nano,git,subversion" > Cygwin64_Agent_Setup.log +IF EXIST "setup-x86_64.exe" setup-x86_64.exe --site "http://cygwin.mirror.constant.com/" --quiet-mode --root "%WD%" --local-package-dir "%WD%\cygTemp" --packages "screen,perl,perl-HTTP-Daemon,perl_vendor,perl-Path-Class,perl-XML-Parser,perl-Archive-Zip,perl-XML-Simple,wget,unzip,gawk,rsync,curl,bzip2,zip,cygrunsrv,dos2unix,mutt,ssmtp,nano,git,subversion,perl-Archive-Extract" > Cygwin64_Agent_Setup.log +IF NOT EXIST "setup-x86_64.exe" setup-x86_64_local.exe --site "http://cygwin.mirror.constant.com/" --quiet-mode --root "%WD%" --local-package-dir "%WD%\cygTemp" --packages "screen,perl,perl-HTTP-Daemon,perl_vendor,perl-Path-Class,perl-XML-Parser,perl-Archive-Zip,perl-XML-Simple,wget,unzip,gawk,rsync,curl,bzip2,zip,cygrunsrv,dos2unix,mutt,ssmtp,nano,git,subversion,perl-Archive-Extract" > Cygwin64_Agent_Setup.log +IF EXIST "setup-x86_64.exe" DEL setup-x86_64_local.exe +cls +REM Creating administrator account +:gameserver_exists +cls +NET USER | FINDSTR gameserver >nul +IF %ERRORLEVEL% neq 0 ( + echo In order to run the agent on boot, + echo we need an administrator account named 'gameserver'. + echo Please, create a new administrator account named 'gameserver' + echo from the control panel of Windows and press any key to continue. + pause >nul + goto :gameserver_exists +) +cls +color C +echo Please, make sure the user 'gameserver' is an administrator account +echo and press any key to continue. +pause >nul +cls +color 7 +FOR /f "tokens=2,3,4 delims=[.]" %%a IN ('ver') DO SET WVer=%%a +FOR /f "tokens=2,3 delims= " %%a IN ('echo %WVer%') DO SET Ver=%%a +set alpha=MNOPQRSTUVW +set DRIVE=M +:set_free_drive +IF EXIST %DRIVE%: ( + call set beta=%%alpha:*%DRIVE%=%% + set DRIVE=%beta:~,1% + goto :set_free_drive +) +:gameserver_pass_ok +set /p PASS=Please, enter the password for user 'gameserver': +IF %VER% LSS 6 ( + grant del SeDenyNetworkLogonRight %USERDOMAIN%\gameserver + net use %DRIVE%: \\%USERDOMAIN%\c$ %PASS% /user:gameserver >nul +) ELSE ( + schtasks /Create /RU "gameserver" /SC ONSTART /TN "testtask" /TR "calc.exe" /F /RL highest /RP %PASS% >nul +) +IF %ERRORLEVEL% NEQ 0 ( + goto :gameserver_pass_ok +) ELSE ( + IF %VER% LSS 6 ( + net use %DRIVE%: /DELETE >nul + grant add SeDenyNetworkLogonRight %USERDOMAIN%\gameserver + ) ELSE ( + schtasks /Delete /TN "testtask" /f >nul + ) +) +cls +REM Old way from SVN +REM tools\wget.exe -N "http://master.dl.sourceforge.net/project/ogpextras/Installer-Snapshot/latest_win_agent_files.zip" -O "agent_files.zip" +tools\wget.exe -N "https://github.com/OpenGamePanel/OGP-Agent-Windows/archive/master.zip" -O "agent_files.zip" --no-check-certificate +unzip -q agent_files_old.zip +unzip -q -o agent_files.zip +IF NOT EXIST "OGP-Agent-Windows-master" unzip -q agent_files_local_copy.zip +cd "OGP-Agent-Windows-master" +IF EXIST OGP/COPYING xcopy /Y /E * ..\ +IF EXIST OGP/COPYING cd .. +rm -rf "OGP-Agent-Windows-master" +rm -f agent_files.zip +rm -f agent_files_old.zip +rm -f agent_files_local_copy.zip +chmod +x /OGP/agent_conf.sh +chmod +x /bin/ogp_agent +REM Run OGP Agent configuration script +bash /OGP/agent_conf.sh -p %PASS% +REM adding OGP Agent to the system startup +tools\fart.exe "%WD%\service_settings.xml" "{COMMAND}" "%WD%\agent_start.bat" +tools\fart.exe "%WD%\service_settings.xml" "{COMMAND_WORK_DIR}" "%WD%" +schtasks /create /tn "OGP agent start on boot" /XML "%WD%\service_settings.xml" /ru "gameserver" /rp "%PASS%" +REM Rebase files +call "%WD%\rebase_post_ins.bat" +echo. +REM Start OGP Agent +schtasks /Run /tn "OGP agent start on boot" +REM Grant logon as a service for FTP / other cyg_win services... needed for FileZilla for sure in x64 installer... not sure about here, but why not put it in. +tools\ntrights.exe +r SeServiceLogonRight -u gameserver -m \\%COMPUTERNAME% +exit 0 diff --git a/Agent-Windows/Install/open_home_path.bat b/Agent-Windows/Install/open_home_path.bat new file mode 100644 index 00000000..fecbf710 --- /dev/null +++ b/Agent-Windows/Install/open_home_path.bat @@ -0,0 +1 @@ +explorer .\home\%USERNAME% \ No newline at end of file diff --git a/Agent-Windows/Install/preuninstall_agent.bat b/Agent-Windows/Install/preuninstall_agent.bat new file mode 100644 index 00000000..dfe63c79 --- /dev/null +++ b/Agent-Windows/Install/preuninstall_agent.bat @@ -0,0 +1,13 @@ +@echo off +set WD=%~dp0 +pushd %WD% +net session >nul 2>&1 +if NOT %errorLevel% == 0 ( + echo Failure: Current permissions inadequate. + echo[ + echo Run this script by using "Run as administrator" in the context menu. + pause >nul + exit +) +net stop ogp_agent +sc delete ogp_agent diff --git a/Agent-Windows/Install/rebase_post_ins.bat b/Agent-Windows/Install/rebase_post_ins.bat new file mode 100644 index 00000000..1f1436e8 --- /dev/null +++ b/Agent-Windows/Install/rebase_post_ins.bat @@ -0,0 +1,20 @@ +@echo off +echo. +echo Stopping OGP Agent if exists... +SET mypath=%~dp0 +IF EXIST "%mypath%\agent_stop.bat" call "%mypath%\agent_stop.bat" +echo. +echo Stopping CygWin Services... +echo. +net stop mysqld +net stop cygserver +net stop httpd +net stop cron +echo. +echo Running CygWin rebaseall command to prevent errors... +echo . +C: +cd "%mypath%\bin" +ash.exe /bin/rebaseall +echo. + diff --git a/Agent-Windows/Install/service_settings.xml b/Agent-Windows/Install/service_settings.xml new file mode 100644 index 00000000..6ebd6293 --- /dev/null +++ b/Agent-Windows/Install/service_settings.xml @@ -0,0 +1,37 @@ + + + + + \OGP agent start on boot + + + + true + + + + + HighestAvailable + + + + false + false + + false + false + + true + false + false + false + PT0S + 5 + + + + C:\OGP64\agent_start.bat + C:\OGP64 + + + diff --git a/Agent-Windows/Install/setup-x86_64.exe b/Agent-Windows/Install/setup-x86_64.exe new file mode 100644 index 00000000..99db6405 Binary files /dev/null and b/Agent-Windows/Install/setup-x86_64.exe differ diff --git a/Agent-Windows/IspConfig/sites_ftp_user_add.php b/Agent-Windows/IspConfig/sites_ftp_user_add.php new file mode 100644 index 00000000..a464fe09 --- /dev/null +++ b/Agent-Windows/IspConfig/sites_ftp_user_add.php @@ -0,0 +1,36 @@ + $soap_location, + 'uri' => $soap_uri, + 'trace' => 1, + 'exceptions' => 1)); +$session_id = $client->login($username,$password); +$client_id = 0; +$username = $_GET['username']; +$password = $_GET['password']; +$dir = $_GET['dir']; +$uid = $_GET['uid']; +$gid = $_GET['gid']; +$params = array( + 'server_id' => 1, + 'parent_domain_id' => 1, + 'username' => $username, + 'password' => $password, + 'quota_size' => -1, + 'active' => 'y', + 'uid' => $uid, + 'gid' => $gid, + 'dir' => $dir, + 'quota_files' => -1, + 'ul_ratio' => -1, + 'dl_ratio' => -1, + 'ul_bandwidth' => -1, + 'dl_bandwidth' => -1 + ); +$ftp_id = $client->sites_ftp_user_add($session_id, $client_id, $params); +$client->logout($session_id); +if(!file_exists('ftp_users')) mkdir('ftp_users'); +chdir('ftp_users'); +file_put_contents($username, $ftp_id); +?> diff --git a/Agent-Windows/IspConfig/sites_ftp_user_delete.php b/Agent-Windows/IspConfig/sites_ftp_user_delete.php new file mode 100644 index 00000000..c7855306 --- /dev/null +++ b/Agent-Windows/IspConfig/sites_ftp_user_delete.php @@ -0,0 +1,15 @@ + $soap_location, + 'uri' => $soap_uri, + 'trace' => 1, + 'exceptions' => 1)); +$session_id = $client->login($username,$password); +chdir('ftp_users'); +$username = $_GET['username']; +$ftp_user_id = file_get_contents($username); +$client->sites_ftp_user_delete($session_id, $ftp_user_id); +unlink($username); +$client->logout($session_id); +?> diff --git a/Agent-Windows/IspConfig/sites_ftp_user_get.php b/Agent-Windows/IspConfig/sites_ftp_user_get.php new file mode 100644 index 00000000..510b94da --- /dev/null +++ b/Agent-Windows/IspConfig/sites_ftp_user_get.php @@ -0,0 +1,24 @@ + $soap_location, + 'uri' => $soap_uri, + 'trace' => 1, + 'exceptions' => 1)); +$session_id = $client->login($username,$password); +chdir('ftp_users'); +$username = $_GET['username']; +$ftp_user_id = file_get_contents($username); +$ftp_user_record = $client->sites_ftp_user_get($session_id, $ftp_user_id); +if(isset($_GET['type']) AND $_GET['type'] == "detail") +{ + foreach($ftp_user_record as $key => $value) + { + echo $key." : ".$value."\n"; + } +} +else +{ + echo $ftp_user_record['username']."\t".$ftp_user_record['dir']."/./\n"; +} +?> diff --git a/Agent-Windows/IspConfig/sites_ftp_user_update.php b/Agent-Windows/IspConfig/sites_ftp_user_update.php new file mode 100644 index 00000000..363d6d82 --- /dev/null +++ b/Agent-Windows/IspConfig/sites_ftp_user_update.php @@ -0,0 +1,31 @@ + $soap_location, + 'uri' => $soap_uri, + 'trace' => 1, + 'exceptions' => 1)); +$session_id = $client->login($username,$password); +$client_id = 0; +chdir('ftp_users'); +$username = $_GET['username']; +$ftp_user_id = file_get_contents($username); +//* Get the ftp user record +$ftp_user_record = $client->sites_ftp_user_get($session_id, $ftp_user_id); +if(isset($_GET['type']) AND $_GET['type'] == "password") +{ + $ftp_user_record['password'] = $_GET['password']; +} +else +{ + $settings = explode("\n",$_GET['password']); + foreach($settings as $setting) + { + list($key,$value) = explode("\t",$setting); + $ftp_user_record[$key] = $value; + } +} + +$client->sites_ftp_user_update($session_id, $client_id, $ftp_user_id, $ftp_user_record); +$client->logout($session_id); +?> diff --git a/Agent-Windows/IspConfig/soap_config.php b/Agent-Windows/IspConfig/soap_config.php new file mode 100644 index 00000000..f037c8e7 --- /dev/null +++ b/Agent-Windows/IspConfig/soap_config.php @@ -0,0 +1,7 @@ + diff --git a/Agent-Windows/KKrcon/HL2.pm b/Agent-Windows/KKrcon/HL2.pm new file mode 100644 index 00000000..90227809 --- /dev/null +++ b/Agent-Windows/KKrcon/HL2.pm @@ -0,0 +1,346 @@ +# HL2 - Perl extension Half-Life 2 (Source) engine Rcon interface +# +# $Id:$ +# + +package HL2; + +use strict; +use warnings; +use IO::Socket; +use IO::Select; + +# release version +our $VERSION = "0.05"; + +# constants for command type +sub CMD { 2 } +sub AUTH { 3 } + +# create class +sub new { + my $class = shift; + + # create object with defaults + my $self = { + hostname => undef, + port => 27015, + password => undef, + timeout => 5, + connected => 0, + authenticated => 0, + socket => undef, + sequence => 0, + }; + + # create object + bless($self, $class); + + # initialize class instances + $self->init(); + + # parse constructor args + while (my ($key, $val) = splice(@_, 0, 2)) { + $key = lc($key); + if ($key eq "hostname") { $self->hostname($val) } + elsif ($key eq "port") { $self->port($val) } + elsif ($key eq "password") { $self->password($val) } + elsif ($key eq "timeout") { $self->timeout($val) } + else { print STDERR "Unknown attribute: $key\n" } + } + + return $self; +} + +# initialize class instances +sub init { + my $self = shift; + my $class = ref($self); + + # manipulate symbol table.. gotta love perl + no strict "refs"; + no warnings; + foreach my $instance (keys %$self) { + *{"${class}::${instance}"} = sub { + my $self = shift; + my $value = shift; + my $ref = \$self->{$instance}; + if (defined $value) { + $$ref = $value; + return $self; + } else { + return $$ref; + } + }; + } +} + +# run a command and return its response +sub run { + my $self = shift; + my $command = shift; + + if (!$self->connected()) { + $self->connect(); + } + + if (!$self->authenticated()) { + $self->authenticate(); + } + + my $socket = $self->socket(); + if($socket->connected) + { + print $socket $self->packet(CMD, $command); + return $self->response(); + } + + return; +} + +# create tcp socket +sub connect { + my $self = shift; + + my $socket = IO::Socket::INET->new( + PeerAddr => $self->hostname(), + PeerPort => $self->port(), + Timeout => $self->timeout(), + Proto => "tcp", + Type => SOCK_STREAM, + ) || die "Failed to connect: $!\n"; + + $self->socket($socket); + $self->connected(1); +} + +# authenticate rcon session +sub authenticate { + my $self = shift; + + # send authentication packet to server + my $socket = $self->socket(); + print $socket $self->packet(AUTH, $self->password()); + + # auth response sends back an empty packet first + $self->response(); + $self->response(); + + $self->authenticated(1); +} + +###################### +# PROTOCOL FUNCTIONS # +###################### + +# rcon command protocol: +# (V)[size] (V)[requestID] (V)[command] (0)[string1] (0)[string2] +# +# rcon response protocol: +# (V)[size] (V)[requestID] (V)[responseID] (0)[string1] (0)[string2] +# +# V = a 32-bit unsigned long int, little-endian (VAX/Intel) +# 0 = null-terminated string +# +# NOTE: string2 appears unused, so our functions ignore it + +# create a packet of type (AUTH or CMD) +sub packet { + my $self = shift; + my $type = shift; + my $payload = shift; + + # sequence increments, but auth + # packet is 2.. no idea why that is, + # but tcpdump does not lie + my $sequence; + if ($type == AUTH) { + $sequence = 2; + } else { + $sequence = $self->sequence(); + + # increment for next use + $self->sequence($sequence + 1); + } + + my $packet = pack("VV", $sequence, $type) . "$payload\x00\x00"; + $packet = pack("V", length($packet)) . $packet; + + return $packet; +} + +# receive packet +sub response { + my $self = shift; + my $payload = $self->read(); + + # remove protocol cruft and null terminators + $payload =~ s/\x00{2}$//; + + return $payload; +} + +# read length of bytes from socket with timeout +sub read { + my $self = shift; + my $length = shift; + + my $socket = $self->socket(); + my $timeout = $self->timeout(); + my $select = IO::Select->new($socket); + + my $reply = ""; + my $buffer; + + my ($size, $request_id, $command_response, $data); + + while ($select->can_read(0.5)) { + $socket->recv($buffer, 4, MSG_PEEK); + $size = unpack("V", $buffer); + last if (!defined($size)); + $socket->recv($buffer, $size+4, MSG_WAITALL); + + ($size, $request_id, $command_response, $data) = + unpack('VVVZ*x', $buffer); + + $reply .= "$data"; + } + + return $reply; +} + +1; + +__END__ + +=head1 NAME + +HL2 - Perl extension Half-Life 2 (Source) engine Rcon interface + +=head1 SYNOPSIS + + use HL2; + my $rcon = HL2->new( + hostname => "insub.org", + password => "yourpass", + timeout => 3, + ); + + print $rcon->run("status"); + $rcon->run("changelevel de_dust"); + +=head1 DESCRIPTION + +Use this module to send "rcon" (remote control) commands to a +Source server, such as Counter-Strike Source. + +=head1 METHODS + +=over 4 + +=item $rcon = HL2->new() + +Create a new rcon object. You can specify the hostname, +password and/or timeout in the constructor, or use the class +methods to change them (see SYNOPSIS). + +=item $rcon->authenticated() + +Returns true if session has succesfully authenticated. + +=item $rcon->password() + +Returns current password, or sets it. Note that setting +this after authentication will not have any effect unless +you reconnect with $rcon->authenticated(0). + +=item $rcon->hostname() + +Returns current hostname, or sets it. + +=item $rcon->port() + +Returns current port, or sets it. Defaults to 27015. + +=item $rcon->sequence() + +Returns the current command sequence. This starts +at 0 and increases with each call. + +=item $rcon->socket() + +Returns the IO::Socket object for the session or +creates a new one if none exists. + +=item $rcon->timeout() + +Returns the TCP response timeout, or sets it. Defaults +to 5. + +=item $rcon->connect() + +Connects to remote server. + +=item $packet = $rcon->packet($type, $payload) + +Creats a packet to send to the remote server. +Type should be either CMD or AUTH, e.g.: + + print $socket $rcon->packet(AUTH, $rcon->password()) + +=item $rcon->authenticate() + +Authenticates with the rcon server. This is done automatically +when you try to run a command. + +=item $response = $rcon->run($command) + +Runs a command on the remote server and returns its response + +=item $response = $rcon->response() + +Reads a response packet from the server. This is called +authomatically when you use run() so you shouldn't need to +use this. + +=back + +=head1 CAVEATS + +This module DOES NOT DO ANY COMMAND VALIDATION. You are responsible for +sending sane commands to the server. If you use this with CGI that allows +internet users to submit console commands, you MUST taint-check this. Users +with RCON access can send anything to the console. I highly recommend that you +restrict what console commands a user can send. + +=head1 BUGS + +As of this writing, there are some bugs with the rcon server itself. +One such bug is that some output goes to the console instead of to +the rcon client. For example, the command "listid" causes the list +of banned users to spew to the physical console instead of back to +the rcon client, making it effectively useless. If you are not getting +back a response you expected, please verify that it's not going to +the console (run srcds in screen so you can access it) before submitting +a bug report to me about it. Or better yet, submit a bug report to Valve. + +Authentication validation is currently unsupported. + +=head1 SEE ALSO + + http://gruntle.org/projects/ + http://insub.org/cs/ + +=head1 AUTHOR + +Chris Jones, Ecjones@gruntle.orgE + +=head1 COPYRIGHT AND LICENSE + + Copyright (C) 2004 by Chris Jones + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself, either Perl version 5.8.5 or, + at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/Agent-Windows/KKrcon/KKrcon.pm b/Agent-Windows/KKrcon/KKrcon.pm new file mode 100644 index 00000000..07f6069d --- /dev/null +++ b/Agent-Windows/KKrcon/KKrcon.pm @@ -0,0 +1,282 @@ +package KKrcon; +# +# KKrcon Perl Module - execute commands on a remote Half-Life server using Rcon. +# http://kkrcon.sourceforge.net +# +# Synopsis: +# +# use KKrcon; +# $rcon = new KKrcon(Password=>PASSWORD, [Host=>HOST], [Port=>PORT], [Type=>"new"|"old"]); +# $result = $rcon->execute(COMMAND); +# %players = $rcon->getPlayers(); +# $player = $rcon->getPlayer(USERID); +# +# Copyright (C) 2000, 2001 Rod May +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# + +use Socket; +use Sys::Hostname; + +# Release version number +$VERSION = "2.11"; + + +## +## Main +## + +# +# Constructor +# + +sub new +{ + my $class_name = shift; + my %params = @_; + + my $self = {}; + bless($self, $class_name); + + my %server_types = (new=>1, old=>2); + + # Check parameters + $params{"Host"} = "127.0.0.1" unless($params{"Host"}); + $params{"Port"} = 27015 unless($params{"Port"}); + $params{"Type"} = "new" unless($params{"Type"}); + + # Initialise properties + $self->{"rcon_password"} = $params{"Password"} + or die("KKrcon: a Password is required\n"); + $self->{"server_host"} = $params{"Host"}; + $self->{"server_port"} = int($params{"Port"}) + or die("KKrcon: invalid Port \"" . $params{"Port"} . "\"\n"); + $self->{"server_type"} = ($server_types{$params{"Type"}} || 1); + + $self->{"error"} = ""; + + # Set up socket parameters + $self->{"_ipaddr"} = gethostbyname($self->{"server_host"}) + or die("KKrcon: could not resolve Host \"" . $self->{"server_host"} . "\"\n"); + + return $self; +} + + + +# +# Execute an Rcon command and return the response +# + +sub execute +{ + my ($self, $command) = @_; + + my $msg; + my $ans; + + if ($self->{"server_type"} == 1) + { + # version x.1.0.6+ HL server + $msg = "\xFF\xFF\xFF\xFFchallenge rcon\n\0"; + $ans = $self->_sendrecv($msg); + + if ($ans =~ /challenge +rcon +(\d+)/) + { + $msg = "\xFF\xFF\xFF\xFFrcon $1 \"" . $self->{"rcon_password"} . "\" $command\0"; + $ans = $self->_sendrecv($msg); + } + elsif (!$self->error()) + { + $ans = ""; + $self->{"error"} = "No challenge response"; + } + } + else + { + # QW/Q2/Q3 or old HL server + $msg = "\xFF\xFF\xFF\xFFrcon " . $self->{"rcon_password"} . " $command\n\0"; + $ans = $self->_sendrecv($msg); + } + + if ($ans =~ /bad rcon_password/i) + { + $self->{"error"} = "Bad Password"; + } + + return $ans; +} + +sub _sendrecv +{ + my ($self, $msg) = @_; + + my $host = $self->{"server_host"}; + my $port = $self->{"server_port"}; + my $ipaddr = $self->{"_ipaddr"}; + + # Open socket + socket(RCON, PF_INET, SOCK_DGRAM, getprotobyname("udp")) or die("KKrcon: socket: $!\n"); + + my $hispaddr = sockaddr_in($port, $ipaddr); + + unless(defined(send(RCON, $msg, 0, $hispaddr))) + { + die("KKrcon: send $ip:$port : $!"); + } + + my $rin; + vec($rin, fileno(RCON), 1) = 1; + my $ans; + + if (select($rin, undef, undef, 10.0)) { + $hispaddr = recv(RCON, $ans, 8192, 0); + + if (defined($ans)) { + $ans =~ s/^\xFF\xFF\xFF\xFFprint\n//; # CoD2 response + $ans =~ s/\x00+$//; # trailing crap + $ans =~ s/^\xFF\xFF\xFF\xFFl//; # HL response + $ans =~ s/^\xFF\xFF\xFF\xFFn//; # QW response + $ans =~ s/^\xFF\xFF\xFF\xFF//; # Q2/Q3 response + $ans =~ s/^\xFE\xFF\xFF\xFF.....//; # old HL bug/feature + + if (length($ans) > 512) { + my $tmp; + my @explode; + + while (select($rin, undef, undef, 0.05)) { + @explode = split(/\n/, $ans); + $explode[$#explode] =~ s/^ //; + $explode[$#explode] = 'X' . $explode[$#explode]; + $ans = join("\n", @explode); + + $hispaddr = recv(RCON, $tmp, 8192, 0); + + if (defined($tmp)) { + $tmp =~ s/^\xFF\xFF\xFF\xFFprint\n//; # CoD2 response + $tmp =~ s/\x00+$//; # trailing crap + $tmp =~ s/^\xFF\xFF\xFF\xFFl//; # HL response + $tmp =~ s/^\xFF\xFF\xFF\xFFn//; # QW response + $tmp =~ s/^\xFF\xFF\xFF\xFF//; # Q2/Q3 response + $tmp =~ s/^\xFE\xFF\xFF\xFF.....//; # old HL bug/feature + $ans .= $tmp; + } + } + } + } + } + + # Close socket + close(RCON); + + if (!defined($ans)) { + $ans = ""; + $self->{"error"} = "Rcon timeout"; + } + + return $ans; +} + + +# +# Get error message +# + +sub error +{ + my ($self) = @_; + + return $self->{"error"}; +} + + + +# +# Parse "status" command output into player information +# + +sub getPlayers +{ + my ($self) = @_; + + my $status = $self->execute("status"); + my @lines = split(/[\r\n]+/, $status); + + my %players; + + foreach $line (@lines) + { + if ($line =~ /^\#[\s\d]\d\s+ + (.+)\s+ # name + (\d+)\s+ # userid + (\d+)\s+ # wonid + ([\d-]+)\s+ # frags + ([\d:]+)\s+ # time + (\d+)\s+ # ping + (\d+)\s+ # loss + (\S+) # addr + $/x) + { + my $name = $1; + my $userid = $2; + my $wonid = $3; + my $frags = $4; + my $time = $5; + my $ping = $6; + my $loss = $7; + my $address = $8; + + $players{$userid} = { + "Name" => $name, + "UserID" => $userid, + "WONID" => $wonid, + "Frags" => $frags, + "Time" => $time, + "Ping" => $ping, + "Loss" => $loss, + "Address" => $address + }; + } + } + + return %players; +} + + +# +# Get information about a player by userID +# + +sub getPlayer +{ + my ($self, $userid) = @_; + + my %players = $self->getPlayers(); + + if (defined($players{$userid})) + { + return $players{$userid}; + } + else + { + $self->{"error"} = "No such player # $userid"; + return 0; + } +} + + +1; +# end diff --git a/Agent-Windows/Minecraft/RCON.pm b/Agent-Windows/Minecraft/RCON.pm new file mode 100644 index 00000000..d06e1184 --- /dev/null +++ b/Agent-Windows/Minecraft/RCON.pm @@ -0,0 +1,544 @@ +# Minecraft::RCON - RCON remote console for Minecraft +# +# 1.x and above by Ryan Thompson +# +# Original (0.1.x) by Fredrik Vold, no copyrights, no rights reserved. +# This is absolutely free software, and you can do with it as you please. +# If you do derive your own work from it, however, it'd be nice with some +# credits to me somewhere in the comments of that work. +# +# Based on http:://wiki.vg/RCON documentation + +package Minecraft::RCON; + +our $VERSION = '1.03'; + +use 5.010; +use strict; +use warnings; +no warnings 'uninitialized'; + +use Term::ANSIColor 3.01; +use IO::Socket 1.18; # autoflush +use Carp; + +use constant { + # Packet types + AUTH => 3, # Minecraft RCON login packet type + AUTH_RESPONSE => 2, # Server auth response + AUTH_FAIL => -1, # Auth failure (password invalid) + COMMAND => 2, # Command packet type + RESPONSE_VALUE => 0, # Server response +}; + +# Minecraft -> ANSI color map +my %COLOR = map { $_->[1] => color($_->[0]) } ( + [black => '0'], [blue => '1'], [green => '2'], + [cyan => '3'], [red => '4'], [magenta => '5'], + [yellow => '6'], [white => '7'], [bright_black => '8'], + [bright_blue => '9'], [bright_green => 'a'], [bright_cyan => 'b'], + [bright_red => 'c'], [bright_magenta => 'd'], [yellow => 'e'], + [bright_white => 'f'], + [bold => 'l'], [concealed => 'm'], [underline => 'n'], + [reverse => 'o'], [reset => 'r'], +); + +# Defaults for new objects. Override in constructor or with accessors. +sub _DEFAULTS(%) { + ( + address => '127.0.0.1', + port => 25575, + password => '', + color_mode => 'strip', + request_id => 0, + + # DEPRECATED options + strip_color => undef, + convert_color => undef, + + @_, # Subclasses may override + ); +} + +# DEPRECATED warning text for convenience/consistency +my $DEP = 'deprecated and will be removed in a future release.'; + +sub new { + my $class = shift; + my %opts = 'HASH' eq ref $_[0] ? %{$_[0]} : @_; + my %DEFAULTS = _DEFAULTS(); + + # DEPRECATED -- Warn and transition to new option + if ($opts{convert_color}) { + carp "convert_color $DEP\nConverted to color_mode => 'convert'."; + $opts{color_mode} = 'convert'; + } + if ($opts{strip_color}) { + carp "strip_color $DEP\nConverted to color_mode => 'strip'."; + $opts{color_mode} = 'strip'; + } + + my @unknowns = grep { not exists $DEFAULTS{$_} } sort keys %opts; + carp "Ignoring unknown option(s): " . join(', ', @unknowns) if @unknowns; + + bless { %DEFAULTS, %opts }, $class; +} + +sub connect { + my ($s) = @_; + + return 1 if $s->connected; + + croak 'Password required' unless length $s->{password}; + + $s->{socket} = IO::Socket::INET->new( + PeerAddr => $s->{address}, + PeerPort => $s->{port}, + Proto => 'tcp', + ) or croak "Connection to $s->{address}:$s->{port} failed: .$!"; + + my $id = $s->_next_id; + $s->_send_encode(AUTH, $id, $s->{password}); + my ($size,$res_id,$type,$payload) = $s->_recv_decode; + + # Force a reconnect if we're about to error out + $s->disconnect unless $type == AUTH_RESPONSE and $id == $res_id; + + croak 'RCON authentication failed' if $res_id == AUTH_FAIL; + croak "Expected AUTH_RESPONSE(2), got $type" if $type != AUTH_RESPONSE; + croak "Expected ID $id, got $res_id" if $id != $res_id; + croak "Non-blank payload <$payload>" if length $payload; + + return 1; +} + +sub connected { $_[0]->{socket} and $_[0]->{socket}->connected } + +sub disconnect { + $_[0]->{socket}->shutdown(2) if $_[0]->connected; + delete $_[0]->{socket} if exists $_[0]->{socket}; + 1; +} + +sub command { + my ($s, $command, $mode) = @_; + + croak 'Command required' unless length $command; + croak 'Not connected' unless $s->connected; + + my $id = $s->_next_id; + my $nonce = 16 + int rand(2 ** 15 - 16); # Avoid 0..15 + $s->_send_encode(COMMAND, $id, $command); + $s->_send_encode($nonce, $id, 'nonce'); + + my $res = ''; + while (1) { + my ($size,$res_id,$type,$payload) = $s->_recv_decode; + if ($id != $res_id) { + $s->disconnect; + croak sprintf( + "Desync. Expected %d (0x%4x), got %d (0x%4x). Disconnected.", + $id, $id, $res_id, $res_id + ); + } + croak "size:$size id:$id got type $type, not RESPONSE_VALUE(0)" + if $type != RESPONSE_VALUE; + last if $payload eq sprintf 'Unknown request %x', $nonce; + $res .= $payload; + } + + $s->color_convert($res, defined $mode ? $mode : $s->{color_mode}); +} + +sub color_mode { + my ($s, $mode, $code) = @_; + return $s->{color_mode} if not defined $mode; + croak 'Invalid color mode.' + unless $mode =~ /^(strip|convert|ignore)$/; + + if ($code) { + my $was = $s->{color_mode}; + $s->{color_mode} = $mode; + $code->(); + $s->{color_mode} = $was; + } else { + $s->{color_mode} = $mode; + } +} + +sub color_convert { + my ($s, $text, $mode) = @_; + $mode = $s->{color_mode} if not defined $mode; + my $re = qr/\x{00A7}(.)/o; + + $text =~ s/$re//g if $mode eq 'strip'; + $text =~ s/$re/$COLOR{$1}/g if $mode eq 'convert'; + $text .= $COLOR{r} if $mode eq 'convert' and $text =~ /\e\[/; + + $text; +} + +sub DESTROY { $_[0]->disconnect } + +# +# DEPRECATED methods +# + +sub convert_color { + my ($s, $val) = @_; + carp "convert_color() is $DEP\nUse color_mode('convert') instead"; + $s->color_mode('convert') if $val; + + $s->color_mode eq 'convert'; +} + +sub strip_color { + my ($s, $val) = @_; + carp "strip_color() is $DEP\nUse color_mode('strip') instead"; + $s->color_mode('strip') if $val; + + $s->color_mode eq 'strip'; +} + +sub address { + carp "address() is $DEP"; + $_[0]->{address} = $_[1] if defined $_[1]; + $_[0]->{address}; +} + +sub port { + carp "port() is $DEP"; + $_[0]->{port} = $_[1] if defined $_[1]; + $_[0]->{port}; +} + +sub password { + carp "password() is $DEP"; + $_[0]->{password} = $_[1] if defined $_[1]; + $_[0]->{password}; +} + +# +# Private helpers +# + +# Increment and return the next request ID, wrapping at 2**31-1 +sub _next_id { $_[0]->{request_id} = ($_[0]->{request_id} + 1) % 2**31 } + +# Form and send a packet of the specified type, request_id and payload +sub _send_encode { + my ($s, $type, $id, $payload) = @_; + confess "Request ID `$id' is not an integer" unless $id =~ /^\d+$/; + $payload = "" unless defined $payload; + my $data = pack('V!V' => $id, $type) . $payload . "\0\0"; + $s->{socket}->send(pack(V => length $data) . $data); + +} + +# Grab a single packet. +sub _recv_decode { + my ($s) = @_; + confess "_recv_decode when not connected" unless $s->connected; + + local $_; $s->{socket}->recv($_, 4); + my $size = unpack 'V'; + $_ = ''; + my $frags = 0; + + croak "Zero length packet" unless $size; + + while ($size > length) { + my $buf; + $s->{socket}->recv($buf, $size); + $_ .= $buf; + $frags++; + } + + croak 'Packet too short. ' . length($_) . ' < 10' if 10 > length($_); + croak "Received packet missing terminator" unless s/\0\0$//; + + $size, unpack 'V!V(A*)'; +} + +1; + +__END__ + +=head1 NAME + +Minecraft::RCON - RCON remote console communication with Minecraft servers + +=head1 VERSION + +Version 1.03 + +=head1 SYNOPSIS + + use Minecraft::RCON; + + my $rcon = Minecraft::RCON->new( { password => 'secret' } ); + + eval { $rcon->connect }; + die "Connection failed: $@" if $@; + + my $response; + eval { $response = $rcon->command('help') }; + say $@ ? "Error: $@" : "Response: $response"; + + $rcon->disconnect; + +=head1 DESCRIPTION + +C provides a nice object interface for talking to Mojang AB's +game Minecraft. Intended for use with their multiplayer servers, specifically +I multiplayer server, as you will need the correct RCON password, and +RCON must be enabled on said server. + +=head1 CONSTRUCTOR + +=head2 new( %options ) + +Create a new RCON object. Note we do not connect automatically; see +C for that. The properties and their defaults are shown below: + + my $rcon = Minecraft::RCON->new({ + address => '127.0.0.1', + port => 25575, + password => '', + color_mode => 'strip', + error_mode => 'error', + }); + +We will C but not die in the event that any unknown options are +provided. + +=over 4 + +=item address + +The hostname or IP address to connect to. + +=item port + +The TCP port number to connect to. + +=item password + +The plaintext password used to authenticate. This password must match the +C line in the F file for your server. + +=item color_mode + +The color mode controls how C handles color codes sent back +by the Minecraft server. It must be one of C, C, or C. +constants. See C for more information. + +=back + +=head1 METHODS + +=head2 connect + + eval { $rcon->connect }; # $@ will be set on error + +Attempt to connect to the configured address and port, and issue the +configured password for authentication. + +If already connected, returns C (nothing to be done). + +This method will C if the connection fails for any reason. +Otherwise, returns a true value. + +=head2 connected + + say "We are connected!" if $rcon->connected; + +Returns true if we have a connected socket, false otherwise. Note that we have +no way to tell if there is a misbehaving Minecraft server on the other +side of that socket, so it is entirely possible for this command (or +C) to succeed, but C calls to fail. + +=head2 disconnect + + $rcon->disconnect; + +Disconnects from the server by closing the socket. Always succeeds. + +=head2 command( $command, [ $color_mode ] ) + + my $response = $rcon->command("data get block $x $y $z"); + my $ansi = $rcon->command('list', 'convert'); + +Sends the C<$command> to the Minecraft server, and synchronously waits for the +response. This method is capable of handling fragmented responses (spread over +several response packets), and will concatenate them all before returning the +result. + +The resulting server response will have its color codes stripped, converted, +or ignored, according to the current C setting, unless a +C<$color_mode> is given, which will override the current setting for this +command only. + +=head2 color_mode( $color_mode, [ $code ] ) + + $rcon->color_mode('strip'); + +When a command response is received, the color codes it contains can be +stripped, converted to ANSI, or left alone, depending on this setting. + +C<$color_mode> is optional, unless C<$code> is also specified. +The valid modes are as follows: + +=over 10 + +=item strip + +Strip any color codes, returning the plaintext. + +=item convert + +Convert any color codes to the equivalent ANSI escape sequences, suitable for +display in a terminal. + +=item ignore + +Ignore color codes, returning the full command response verbatim. + +=back + +The current mode will be returned. + +If C<$code> is specified and is a C ref, C will apply the +new color mode, run C<$code-E()>, and then restore the original color +mode. This is useful when you use one color mode most of the time, but have +sections of code requiring a different mode: + +Example usage: + + # Color mode is 'convert' + $rcon->color_mode(strip => sub { + my $plaintext = $rcon->command('...'); + }); + +But see also C for running single commands with +another color mode. + + +=head2 color_convert( $string, [ $color_mode ] ) + + my $response = $rcon->command('list'); + my ($strip, $ansi) = map { $rcon->color_convert($response, $_) } + qw; + +This method is used internally by C to convert command responses as +configured in the object. However, C itself may be useful in +some applications where a stripped version of the response may be needed for +parsing, while an ANSI version may be desired for display to a terminal, for +example, without having to run the command itself (with possible side-effects) +a second time. For C to do anything meaningful, your object's +C should be set to C. + +=head1 ERROR HANDLING + +This module Cs (see L) for almost all errors. +When an error does not affect control flow, we will C instead. + +Thus, C and C, at minimum, should be wrapped in block +C: + + eval { $result = $rcon->command('list'); }; + warn "I don't know who is online because: $@" if $@; + +If a little extra syntactic sugar is desired, you can use an exception handler +like L instead: + + use Try::Tiny; + + try { + $result = $rcon->command('list'); + } catch { + warn "I don't know who is online because: $_"; + } + +=head1 DEPRECATED METHODS + +The following methods have been deprecated. They will issue a warning to +STDOUT when called, and will be removed in a future release. + +=head2 convert_color ( $enable ) + +If C<$enable> is a true value, change the color mode to C. +Returns 1 if the current color mode is C, undef otherwise. + +B Use C instead. + +=head2 strip_color + +If C<$enable> is a true value, change the color mode to C. +Returns 1 if the current color mode is C, undef otherwise. + +B Use C instead. + +=head1 SUPPORT + +=over 4 + +=item L: Source code repository + +=item L: Bug reports and feature requests + +=back + +=head1 SEE ALSO + +=over 4 + +=item L for an alternative API + +=item L, L + +=item L + +=item L + +=back + +=head1 AFFILIATION WITH MOJANG + +I + +I am in no way affiliated with Mojang or the development of Minecraft. +I'm simply a fan of their work, and a server admin myself. I needed +some RCON magic for my servers website, and there was no perl module. + +It is important that everyone using this module understands that if +Mojang changes the way RCON works, I won't be notified any sooner than +anyone else, and I have no special avenue of connection with them. + +=head1 AUTHORS + +=over 4 + +=item B Crjt@cpan.orgE> + +Addition of unit test suite, fragmentation support, and other improvements. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +L + +=item B Cfredrik@webkonsept.comE> + +Original (0.1.x) author. + +No copyright claimed, no rights reserved. + +You are absolutely free to do as you wish with this code, but mentioning me in +your comments or whatever would be nice. + +Minecraft is a trademark of Mojang AB. Name used in accordance with my +interpretation of L, to the best of my +knowledge. + +=back diff --git a/Agent-Windows/README.md b/Agent-Windows/README.md new file mode 100644 index 00000000..3897fe64 --- /dev/null +++ b/Agent-Windows/README.md @@ -0,0 +1,31 @@ +# GSP Windows Agent + +Cygwin-based agent that lets the GameServer Panel manage Windows Server 2019/2022 hosts. It mirrors the Linux agent feature set: signed RPC transport, GNU Screen session management, and SteamCMD-aware installers. + +## Highlights + +- One-click installer (`Install/onceinstall_agent.bat`) that bootstraps Cygwin, required packages, and the `gameserver` service account. +- Task Scheduler entry that keeps the agent running after reboots. +- Helper scripts (`agent_conf.sh`, `rebase_post_ins.bat`, etc.) for maintaining the environment. +- Markdown documentation under [`documentation/agent-guide.md`](documentation/agent-guide.md). + +## Quick start + +1. Clone or download the repository to `C:\\gsp-agent`. +2. Right-click `Install\\onceinstall_agent.bat` → “Run as administrator”. +3. Open the bundled Cygwin terminal and configure the agent: + ```bash + cd /OGP + bash agent_conf.sh -p "gameserverPassword" + ``` +4. Edit `C:\\OGP\\Cfg\\Config.pm` so it matches the server entry you created in the GameServer Panel. +5. Start the “OGP agent start on boot” scheduled task (or reboot). + +## Related repositories + +- [GSP](https://github.com/GameServerPanel/GSP) – PHP panel that issues commands to the agents. +- [GSP-Agent-Linux](https://github.com/GameServerPanel/GSP-Agent-Linux) – Linux counterpart with systemd service files. + +## Contributing + +Send pull requests through GitHub. Test installer changes on a clean Windows Server VM, keep batch files in ASCII, and update `documentation/agent-guide.md` whenever you modify the workflow. diff --git a/Agent-Windows/Schedule/Cron.pm b/Agent-Windows/Schedule/Cron.pm new file mode 100644 index 00000000..13f6ec68 --- /dev/null +++ b/Agent-Windows/Schedule/Cron.pm @@ -0,0 +1,1915 @@ +#!/usr/bin/perl -w + +=head1 NAME + +Cron - cron-like scheduler for Perl subroutines + +=head1 SYNOPSIS + + use Schedule::Cron; + + # Subroutines to be called + sub dispatcher { + print "ID: ",shift,"\n"; + print "Args: ","@_","\n"; + } + + sub check_links { + # do something... + } + + # Create new object with default dispatcher + my $cron = new Schedule::Cron(\&dispatcher); + + # Load a crontab file + $cron->load_crontab("/var/spool/cron/perl"); + + # Add dynamically crontab entries + $cron->add_entry("3 4 * * *",ROTATE => "apache","sendmail"); + $cron->add_entry("0 11 * * Mon-Fri",\&check_links); + + # Run scheduler + $cron->run(detach=>1); + + +=head1 DESCRIPTION + +This module provides a simple but complete cron like scheduler. I.e this +module can be used for periodically executing Perl subroutines. The dates and +parameters for the subroutines to be called are specified with a format known +as crontab entry (see L<"METHODS">, C and L) + +The philosophy behind C is to call subroutines periodically +from within one single Perl program instead of letting C trigger several +(possibly different) Perl scripts. Everything under one roof. Furthermore, +C provides mechanism to create crontab entries dynamically, +which isn't that easy with C. + +C knows about all extensions (well, at least all extensions I'm +aware of, i.e those of the so called "Vixie" cron) for crontab entries like +ranges including 'steps', specification of month and days of the week by name, +or coexistence of lists and ranges in the same field. It even supports a bit +more (like lists and ranges with symbolic names). + +=head1 METHODS + +=over 4 + +=cut + +#' + +package Schedule::Cron; + +use Time::ParseDate; +use Data::Dumper; + +use strict; +use vars qw($VERSION $DEBUG); +use subs qw(dbg); + +my $HAS_POSIX; + +BEGIN { + eval { + require POSIX; + import POSIX ":sys_wait_h"; + }; + $HAS_POSIX = $@ ? 0 : 1; +} + + +$VERSION = "1.02_3"; + +our $DEBUG = 0; +my %STARTEDCHILD = (); + +my @WDAYS = qw( + Sunday + Monday + Tuesday + Wednesday + Thursday + Friday + Saturday + Sunday + ); + +my @ALPHACONV = ( + { }, + { }, + { }, + { qw(jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8 + sep 9 oct 10 nov 11 dec 12) }, + { qw(sun 0 mon 1 tue 2 wed 3 thu 4 fri 5 sat 6)}, + { } + ); +my @RANGES = ( + [ 0,59 ], + [ 0,23 ], + [ 0,31 ], + [ 0,12 ], + [ 0,7 ], + [ 0,59 ] + ); + +my @LOWMAP = ( + {}, + {}, + { 0 => 1}, + { 0 => 1}, + { 7 => 0}, + {}, + ); + + +# Currently, there are two ways for reaping. One, which only waits explicitly +# on PIDs it forked on its own, and one which waits on all PIDs (even on those +# it doesn't forked itself). The later has been proved to work on Win32 with +# the 64 threads limit (RT #56926), but not when one creates forks on ones +# own. The specific reaper works for RT #55741. + +# It tend to use the specific one, if it also resolves RT #56926. Both are left +# here for reference until a decision has been done for 1.01 + +sub REAPER { + &_reaper_all(); +} + +# Specific reaper +sub _reaper_specific { + local ($!,%!,$?); + if ($HAS_POSIX) + { + foreach my $pid (keys %STARTEDCHILD) { + if ($STARTEDCHILD{$pid}) { + my $res = $HAS_POSIX ? waitpid($pid, WNOHANG) : waitpid($pid,0); + if ($res > 0) { + # We reaped a truly running process + $STARTEDCHILD{$pid} = 0; + dbg "Reaped child $res" if $DEBUG; + } + } + } + } + else + { + my $waitedpid = 0; + while($waitedpid != -1) { + $waitedpid = wait; + } + } +} + +# Catch all reaper +sub _reaper_all { + #local ($!,%!,$?,${^CHILD_ERROR_NATIVE}); + + # Localizing ${^CHILD_ERROR_NATIVE} breaks signalhander.t which checks that + # chained SIGCHLD handlers are called. I don't know why, though, hence I + # leave it out for now. See #69916 for some discussion why this handler + # might be needed. + local ($!,%!,$?); + my $kid; + do + { + # Only on POSIX systems the wait will return immediately + # if there are no finished child processes. Simple 'wait' + # waits blocking on childs. + $kid = $HAS_POSIX ? waitpid(-1, WNOHANG) : wait; + dbg "Kid: $kid" if $DEBUG; + if ($kid != 0 && $kid != -1 && defined $STARTEDCHILD{$kid}) + { + # We don't delete the hash entry here to avoid an issue + # when modifying global hash from multiple threads + $STARTEDCHILD{$kid} = 0; + dbg "Reaped child $kid" if $DEBUG; + } + } while ($kid != 0 && $kid != -1); + + # Note to myself: Is the %STARTEDCHILD hash really necessary if we use -1 + # for waiting (i.e. for waiting on any child ?). In the current + # implementation, %STARTEDCHILD is not used at all. It would be only + # needed if we iterate over it to wait on pids specifically. +} + +# Cleaning is done in extra method called from the main +# process in order to avoid event handlers modifying this +# global hash which can lead to memory errors. +# See RT #55741 for more details on this. +# This method is called in strategic places. +sub _cleanup_process_list +{ + my ($self, $cfg) = @_; + + # Cleanup processes even on those systems, where the SIGCHLD is not + # propagated. Only do this for POSIX, otherwise this call would block + # until all child processes would have been finished. + # See RT #56926 for more details. + + # Do not cleanup if nofork because jobs that fork will do their own reaping. + &REAPER() if $HAS_POSIX && !$cfg->{nofork}; + + # Delete entries from this global hash only from within the main + # thread/process. Hence, this method must not be called from within + # a signalhandler + for my $k (keys %STARTEDCHILD) + { + delete $STARTEDCHILD{$k} unless $STARTEDCHILD{$k}; + } +} + +=item $cron = new Schedule::Cron($dispatcher,[extra args]) + +Creates a new C object. C<$dispatcher> is a reference to a subroutine, +which will be called by default. C<$dispatcher> will be invoked with the +arguments parameter provided in the crontab entry if no other subroutine is +specified. This can be either a single argument containing the argument +parameter literally has string (default behavior) or a list of arguments when +using the C option described below. + +The date specifications must be either provided via a crontab like file or +added explicitly with C (L<"add_entry">). + +I can be a hash or hash reference for additional arguments. The +following parameters are recognized: + +=over + +=item file => + + +Load the crontab entries from + +=item eval => 1 + +Eval the argument parameter in a crontab entry before calling the subroutine +(instead of literally calling the dispatcher with the argument parameter as +string) + +=item nofork => 1 + +Don't fork when starting the scheduler. Instead, the jobs are executed within +current process. In your executed jobs, you have full access to the global +variables of your script and hence might influence other jobs running at a +different time. This behaviour is fundamentally different to the 'fork' mode, +where each jobs gets its own process and hence a B of the process space, +independent of each other job and the main process. This is due to the nature +of the C system call. + +=item nostatus => 1 + +Do not update status in $0. Set this if you don't want ps to reveal the internals +of your application, including job argument lists. Default is 0 (update status). + +=item skip => 1 + +Skip any pending jobs whose time has passed. This option is only useful in +combination with C where a job might block the execution of the +following jobs for quite some time. By default, any pending job is executed +even if its scheduled execution time has already passed. With this option set +to true all pending which would have been started in the meantime are skipped. + +=item catch => 1 + +Catch any exception raised by a job. This is especially useful in combination with +the C option to avoid stopping the main process when a job raises an +exception (dies). + +=item after_job => \&after_sub + +Call a subroutine after a job has been run. The first argument is the return +value of the dispatched job, the reminding arguments are the arguments with +which the dispatched job has been called. + +Example: + + my $cron = new Schedule::Cron(..., after_job => sub { + my ($ret,@args) = @_; + print "Return value: ",$ret," - job arguments: (",join ":",@args,")\n"; + }); + +=item log => \&log_sub + +Install a logging subroutine. The given subroutine is called for several events +during the lifetime of a job. This method is called with two arguments: A log +level of 0 (info),1 (warning) or 2 (error) depending on the importance of the +message and the message itself. + +For example, you could use I (L) for logging +purposes for example like in the following code snippet: + + use Log::Log4perl; + use Log::Log4perl::Level; + + my $log_method = sub { + my ($level,$msg) = @_; + my $DBG_MAP = { 0 => $INFO, 1 => $WARN, 2 => $ERROR }; + + my $logger = Log::Log4perl->get_logger("My::Package"); + $logger->log($DBG_MAP->{$level},$msg); + } + + my $cron = new Schedule::Cron(.... , log => $log_method); + +=item loglevel => <-1,0,1,2> + +Restricts logging to the specified severity level or below. Use 0 to have all +messages generated, 1 for only warnings and errors and 2 for errors only. +Default is 0 (all messages). A loglevel of -1 (debug) will include job +argument lists (also in $0) in the job start message logged with a level of 0 +or above. You may have security concerns with this. Unless you are debugging, +use 0 or higher. A value larger than 2 will disable logging completely. + +Although you can filter in your log routine, generating the messages can be +expensive, for example if you pass arguments pointing to large hashes. Specifying +a loglevel avoids formatting data that your routine would discard. + +=item processprefix => + +Cron::Schedule sets the process' name (i.e. C<$0>) to contain some informative +messages like when the next job executes or with which arguments a job is +called. By default, the prefix for this labels is C. With this +option you can set it to something different. You can e.g. use C<$0> to include +the original process name. You can inhibit this with the C option, and +prevent the argument display by setting C to zero or higher. + +=item sleep => \&hook + +If specified, &hook will be called instead of sleep(), with the time to sleep +in seconds as first argument and the Schedule::Cron object as second. This hook +allows you to use select() instead of sleep, so that you can handle IO, for +example job requests from a network connection. + +e.g. + + $cron->run( { sleep => \&sleep_hook, nofork => 1 } ); + + sub sleep_hook { + my ($time, $cron) = @_; + + my ($rin, $win, $ein) = ('','',''); + my ($rout, $wout, $eout); + vec($rin, fileno(STDIN), 1) = 1; + my ($nfound, $ttg) = select($rout=$rin, $wout=$win, $eout=$ein, $time); + if ($nfound) { + handle_io($rout, $wout, $eout); + } + return; +} + +=back + +=cut + +sub new +{ + my $class = shift; + my $dispatcher = shift || die "No dispatching sub provided"; + die "Dispatcher not a ref to a subroutine" unless ref($dispatcher) eq "CODE"; + my $cfg = ref($_[0]) eq "HASH" ? $_[0] : { @_ }; + $cfg->{processprefix} = "Schedule::Cron" unless $cfg->{processprefix}; + my $timeshift = $cfg->{timeshift} || 0; + my $self = { + cfg => $cfg, + dispatcher => $dispatcher, + timeshift => $timeshift, + queue => [ ], + map => { } + }; + bless $self,(ref($class) || $class); + + $self->load_crontab if $cfg->{file}; + $self; +} + +=item $cron->load_crontab($file) + +=item $cron->load_crontab(file=>$file,[eval=>1]) + +Loads and parses the crontab file C<$file>. The entries found in this file will +be B to the current time table with C<$cron-Eadd_entry>. + +The format of the file consists of cron commands containing of lines with at +least 5 columns, whereas the first 5 columns specify the date. The rest of the +line (i.e columns 6 and greater) contains the argument with which the +dispatcher subroutine will be called. By default, the dispatcher will be +called with one single string argument containing the rest of the line +literally. Alternatively, if you call this method with the optional argument +C1> (you must then use the second format shown above), the rest of +the line will be evaled before used as argument for the dispatcher. + +For the format of the first 5 columns, please see L<"add_entry">. + +Blank lines and lines starting with a C<#> will be ignored. + +There's no way to specify another subroutine within the crontab file. All +calls will be made to the dispatcher provided at construction time. + +If you want to start up fresh, you should call +C<$cron-Eclean_timetable()> before. + +Example of a crontab fiqw(le:) + + # The following line runs on every Monday at 2:34 am + 34 2 * * Mon "make_stats" + # The next line should be best read in with an eval=>1 argument + * * 1 1 * { NEW_YEAR => '1',HEADACHE => 'on' } + +=cut + +#' + +sub load_crontab +{ + my $self = shift; + my $cfg = shift; + + if ($cfg) + { + if (@_) + { + $cfg = ref($cfg) eq "HASH" ? $cfg : { $cfg,@_ }; + } + elsif (!ref($cfg)) + { + my $new_cfg = { }; + $new_cfg->{file} = $cfg; + $cfg = $new_cfg; + } + } + + my $file = $cfg->{file} || $self->{cfg}->{file} || die "No filename provided"; + my $eval = $cfg->{eval} || $self->{cfg}->{eval}; + + open(F,$file) || die "Cannot open schedule $file : $!"; + my $line = 0; + while () + { + $line++; + # Strip off trailing comments and ignore empty + # or pure comments lines: + s/#.*$//; + next if /^\s*$/; + next if /^\s*#/; + chomp; + s/\s*(.*)\s*$/$1/; + my ($min,$hour,$dmon,$month,$dweek,$rest) = split (/\s+/,$_,6); + + my $time = [ $min,$hour,$dmon,$month,$dweek ]; + + # Try to check, whether an optional 6th column specifying seconds + # exists: + my $args; + if ($rest) + { + my ($col6,$more_args) = split(/\s+/,$rest,2); + if ($col6 =~ /^[\d\-\*\,\/]+$/) + { + push @$time,$col6; + dbg "M: $more_args"; + $args = $more_args; + } + else + { + $args = $rest; + } + } + $self->add_entry($time,{ 'args' => $args, 'eval' => $eval}); + } + close F; +} + +=item $cron->add_entry($timespec,[arguments]) + +Adds a new entry to the list of scheduled cron jobs. + +B