NetSDS-1.301/0000755000076400007640000000000011277046434011622 5ustar mishamishaNetSDS-1.301/lib/0000755000076400007640000000000011277046434012370 5ustar mishamishaNetSDS-1.301/lib/NetSDS/0000755000076400007640000000000011277046434013470 5ustar mishamishaNetSDS-1.301/lib/NetSDS/Session.pm0000444000076400007640000001352111276226752015453 0ustar mishamisha#=============================================================================== # # MODULE: NetSDS::Session # # DESCRIPTION: Memcached based session data storage # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # #=============================================================================== =head1 NAME B - memcached based session storage API =head1 SYNOPSIS use NetSDS::Session; # Connecting to Memcached server my $sess = NetSDS::Session->new( host => '12.34.56.78', port => '12345', ); ... # Retrieve session key somehow $session_key = $cgi->param('sess_key'); $sess->open($session_key); my $filter = $sess->get('filter'); ... $sess->set('filter', $new_filter); ... $sess->close(); 1; =head1 DESCRIPTION C module provides API to session data storage based on Memcached server. Each session represented as hash reference structure identified by UUID string. Most reasonable usage of this module is a temporary data storing for web based GUI between HTTP requests. However it's possible to find some other tasks. Internally session structure is transformed to/from JSON string when interacting with Memcached. =cut package NetSDS::Session; use 5.8.0; use strict; use warnings; use version; our $VERSION = '1.301'; use Cache::Memcached::Fast; use JSON; use base 'NetSDS::Class::Abstract'; =head1 CLASS API =over =item B - class constructor Constructor establish connection to memcached server and set default session parameters. Parameters: * host - memcached server hostname or IP address (default: 127.0.0.1) * port - memcached server TCP port (default: 11211) Example: my $sess_hdl = NetSDS::Session->new( host => '12.34.56.78', port => '99999', ); =cut sub new { my ( $class, %params ) = @_; my $self = $class->SUPER::new( session_id => undef, # session id (UUID string) session_data => {}, # session data as hash reference %params ); # Prepare server address string (host:port) my $mc_host = $params{'host'} || '127.0.0.1'; my $mc_port = $params{'port'} || '11211'; # Initialize memcached handler $self->{memcached} = Cache::Memcached::Fast->new( { servers => [ { address => $mc_host . ':' . $mc_port } ], serialize_methods => [ \&JSON::encode_json, \&JSON::decode_json ], } ); if ( $self->{memcached} ) { return $self; } else { return $class->error("Can't create memcached connection handler"); } } ## end sub new =item B - open session Retrieve session data from server by session key (UUID string) If no session exists then empty hashref is returned. =cut sub open { my ( $self, $sess_id ) = @_; # Initialize session key and retrieve data $self->{_id} = $sess_id; $self->{_data} = $self->{memcached}->get($sess_id); # If no such session stored then create empty hashref $self->{_data} ||= {}; return $self; } =item B - get session id Returns current session id. Example: my $sess_id = $sess->id(); =cut sub id { my $self = shift; return $self->{_id}; } =item B - set session parameter Set new session parameter value identified by it's key. Example: $sess->set('order', 'id desc'); =cut sub set { my ( $self, $key, $value ) = @_; $self->{_data}->{$key} = $value; return 1; } =item B - get session parameter Return session parameter value by it's key. Example: my $order = $sess->get('order'); =cut sub get { my ( $self, $key ) = @_; return $self->{_data}->{$key}; } =item B - delete session parameter by key Delete session parameter by it's key. Returns updated session data as hash reference. Example: $sess->delete('order'); =cut sub delete { my ( $self, $key ) = @_; delete $self->{_data}->{$key}; return $self->{_data}; } =item B - clear session data This method clears all session data. Example: $sess->clear(); =cut sub clear { my $self = shift; $self->{_data} = {}; } =item B - save session Synchronize session data on Memcached server. Example: $sess->sync(); =cut sub sync { my $self = shift; return $self->id ? $self->{memcached}->set( $self->id, $self->{_data} ) : undef; } =item B - save and close session This method save all data to server and clear current session id and data from object. Example: $session->close(); =cut sub close { my $self = shift; # Nothing to store for non existent session key unless ( $self->id ) { return undef; } # Store session data to memcached server # or clear it from server if it's empty if ( $self->{_data} == {} ) { $self->{memcached}->delete( $self->id ); } else { $self->{memcached}->set( $self->id, $self->{_data} ); } # Clear session id and data $self->{_id} = undef; $self->{_data} = undef; return; } ## end sub close 1; __END__ =back =head1 SEE ALSO =over =item * L - XS implementation of Memcached API =item * L - JSON encoding/decoding API =back =head1 AUTHORS Michael Bochkaryov =head1 THANKS Yana Kornienko - for initial module implementation =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/DBI/0000755000076400007640000000000011277046434014066 5ustar mishamishaNetSDS-1.301/lib/NetSDS/DBI/Table.pm0000555000076400007640000002752211276226752015466 0ustar mishamisha#=============================================================================== # # FILE: Table.pm # # DESCRIPTION: NetSDS::DBI::Table - CRUD implementation for NetSDS # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 25.07.2008 01:06:46 EEST #=============================================================================== =head1 NAME NetSDS::DBI::Table =head1 SYNOPSIS use NetSDS::DBI::Table; my $q = NetSDS::DBI::Table->new( dsn => 'dbi:Pg:dbname=netsdsdb;host=127.0.0.1', user => 'netsds', passwd => 'test', table => 'public.messages', ) or warn NetSDS::DBI::Table->errstr(); =head1 DESCRIPTION C module provides commonly used CRUD functionality for data stored in single database. Main idea was that we can agree about some limitations: * every such table contains C field that is primary key * we use PostgreSQL DBMS with all it's features =cut package NetSDS::DBI::Table; use 5.8.0; use strict; use warnings; use base 'NetSDS::DBI'; use version; our $VERSION = '1.301'; #=============================================================================== # =head1 CLASS API =over =item B - class constructor my $tbl = NetSDS::DBI::Table->new( dsn => 'dbi:Pg:dbname=content', login => 'netsds', passwd => 'topsecret, table => 'content.meta', ); =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; # Initialize base DBMS connector my $self = $class->SUPER::new(%params); # Set table name if ( $params{table} ) { $self->{table} = $params{table}; } else { return $class->error('Table name is not specified to NetSDS::DBI::Table'); } # 'fields' paramter is hash reference describing supported/allowed fields if ( $params{fields} ) { } return $self; } ## end sub new #*********************************************************************** =item B - get records from table as array of hashrefs Paramters (hash): * fields - fetch fields by list * filter - arrayref of SQL expressions like C for C clause * order - arrayref of SQL expressions like C for C clause * limit - max number of records to fetch (LIMIT N) * offset - records to skip from beginning (OFFSET N) * for_update - records selected for further update within current transaction Returns: message as array of hashrefs Sample: my @messages = $q->fetch( fields => ['id', 'now() as time'], filter => ['msg_status = 5', 'date_received < now()'], # where msg_status=5 and date_received < now() order => ['id desc', 'src_addr'], # order by id desc, src_addr limit => 3, # fetch 3 records offset => 5, # from 6-th record for_update => 1, # for update ) =cut #----------------------------------------------------------------------- sub fetch { my ( $self, %params ) = @_; # Prepare expected fields list my $req_fields = $params{fields} ? join( ',', @{ $params{fields} } ) : '*'; # Set default filter my $default_filter = $self->{default_filter} ? " where " . join( " and ", @{ $self->{default_filter} } ) : ''; # Prepare WHERE filter my $req_filter = ($params{filter} and grep { $_ } @{ $params{filter} }) ? " where " . join( " and ", grep { $_ } @{ $params{filter} } ) : $default_filter; # Prepare results order my $req_order = $params{order} ? " order by " . join( ", ", @{ $params{order} } ) : ''; # Set limit and offset for fetching my $req_limit = $params{limit} ? " limit " . $params{limit} : ''; my $req_offset = $params{offset} ? " offset " . $params{offset} : ''; # Request for messages my $sql = "select $req_fields from " . $self->{table} . " $req_filter $req_order $req_limit $req_offset"; # Set FOR UPDATE if necessary if ( $params{for_update} ) { $sql .= " for update"; } # Execute SQL query and fetch results my @ret = (); my $sth = $self->call($sql); while ( my $row = $sth->fetchrow_hashref() ) { push @ret, $row; } return @ret; } ## end sub fetch #*********************************************************************** =item B - insert record into table Paramters: record fields as hash Returns: id of inserted record my $user_id = $tbl->insert_row( 'login' => 'vasya', 'password' => $encrypted_passwd, ); =cut #----------------------------------------------------------------------- sub insert_row { my ( $self, %params ) = @_; my @fields = (); # Fields list my @values = (); # Values list # Prepare fields and values lists from input hash foreach my $key ( keys %params ) { push @fields, $key; push @values, $self->dbh->quote( $params{$key} ); } my $return_value = $self->has_field('id') ? ' returning id' : ''; # Prepare SQL statement from fields and values lists my $sql = 'insert into ' . $self->{table} . ' (' . join( ',', @fields ) . ')' # fields list . ' values (' . join( ',', @values ) . ')' # values list . $return_value; # return "id" field # Execute SQL query and fetch result my $sth = $self->call($sql); my ($row_id) = $return_value ? $sth->fetchrow_array : $sth->rows; # Return "id" field from inserted row return $row_id || $self->error( "Can't insert table record: " . $self->dbh->errstr ); } ## end sub insert_row #*********************************************************************** =item B - mass insert Paramters: list of records (as hashrefs) Returns: array of inserted records "id" This method allows mass insert of records. my @user_ids = $tbl->insert( { login => 'vasya', password => $str1 }, { login => 'masha', password => $str2 }, { login => 'petya', password => $str3, active => 'false' }, ); B This method use separate INSERT queries and in fact is only wrapper for multiple C calls. So it's not so fast as one insert but allows to use different key-value pairs for different records. =cut #----------------------------------------------------------------------- sub insert { my ( $self, @rows ) = @_; my @ids = (); # Go through records and insert each one foreach my $rec (@rows) { push @ids, ( $self->insert_row( %{$rec} ) ); } return @ids; } #*********************************************************************** =item B - update record parameters Paramters: id, new parameters as hash Returns: updated record as hash Example: my %upd = $table->update_row($msg_id, status => 'failed', dst_addr => '380121234567', ); After this %upd hash will contain updated table record. =cut #----------------------------------------------------------------------- sub update_row { my ( $self, $id, %params ) = @_; my @up = (); foreach my $key ( keys %params ) { push @up, "$key = " . $self->dbh->quote( $params{$key} ); } my $sql = "update " . $self->{table} . " set " . join( ', ', @up ) . " where id=$id"; my $res = $self->call($sql); if ($res) { return %{$res}; } else { return $self->error( "Can't update table row: " . $self->dbh->errstr ); } } #*********************************************************************** =item B - update records by filter Paramters: filter, new values $tbl->update( filter => ['active = true', 'created > '2008-01-01'], set => { info => 'Created after 2007 year', } ); =cut #----------------------------------------------------------------------- sub update { my ( $self, %params ) = @_; # Prepare WHERE filter my $req_filter = $params{filter} ? " where " . join( " and ", @{ $params{filter} } ) : ''; my @up = (); foreach my $key ( keys %{ $params{set} } ) { push @up, "$key = " . $self->dbh->quote( $params{set}->{$key} ); } my $sql = "update " . $self->{table} . " set " . join( ', ', @up ) . $req_filter; my $res = $self->call($sql); if ($self->dbh->errstr) { $self->error( "Can't update table: " . $self->dbh->errstr ); return; }; return 1; } #*********************************************************************** =item B - retrieve number of records Just return total number of records by calling: # SELECT COUNT(id) FROM schema.table my $count = $tbl->get_count(); my $count_active = $tbl->get_count(filter => ['active = true']); =cut #----------------------------------------------------------------------- ## Returns number of records sub get_count { my $self = shift; my $filter = \@_; # Fetch number of records # SQL: select count(id) as c from $table where [filter] my @count = $self->fetch( fields => ['count(id) as c'], filter => $filter, ); return $count[0]->{c}; } #*********************************************************************** =item B - delete records by identifier Paramters: list of record id Returns: 1 if ok, undef if error Method deletes records from SQL table by it's identifiers. if ($tbl->remove(5, 8 ,19)) { print "Records successfully removed."; } =cut #----------------------------------------------------------------------- sub delete_by_id { my ( $self, @ids ) = @_; # TODO check for too long @id list # Prepare SQL condition my $in_cond = "id in (" . join( ", ", @ids ) . ")"; my $sql = "delete from " . $self->{table} . " where $in_cond"; if ( $self->call($sql) ) { return 1; } else { return $self->error( "Can't delete records by Id: table='" . $self->{table} . "'" ); } } #*********************************************************************** =item B - delete records Paramters: list of filters Returns: 1 if ok, undef if error $tbl->delete( 'active = false', 'expire < now()', ); =cut #----------------------------------------------------------------------- sub delete { my ( $self, @filter ) = @_; # Prepare WHERE filter my $req_filter = " where " . join( " and ", @filter ); # Remove records $self->call( "delete from " . $self->{table} . $req_filter ); } #*********************************************************************** =item B - get list of fields Example: my @fields = @{ $tbl->get_fields() }; print "Table fields: " . join (', ', @fields); =cut #----------------------------------------------------------------------- sub get_fields { return [ keys %{ +shift->{'fields'} } ]; } #*********************************************************************** =item B - check if field exists Paramters: field name Example: if ($tbl->has_field('uuid')) { $tbl->call("delete tbldata where uuid=?", $uuid); } B: this method works only for restricted tables that use C parameter at construction time. =cut #----------------------------------------------------------------------- sub has_field { # TODO # - check if fields defined at all # - think about multiple values return $_[0]->{'fields'}{ $_[1] } } 1; __END__ =back =head1 EXAMPLES See C script =head1 BUGS Bad documentation =head1 SEE ALSO L L =head1 TODO None =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/Logger.pm0000444000076400007640000001142411276226752015247 0ustar mishamisha#=============================================================================== # # FILE: Logger.pm # # DESCRIPTION: Syslog wrapper for Net SDS # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 25.04.2008 17:32:37 EEST #=============================================================================== =head1 NAME NetSDS::Logger - syslog wrapper for applications and classes =head1 SYNOPSIS use NetSDS::Logger; my $logger = NetSDS::Logger->new( name => 'NetSDS-SuperDaemon', ); $logger->log("info", "Syslog message here"); =head1 DESCRIPTION This module contains implementation of logging functionality for NetSDS components. By default, messages are logged with C facility and C options. B: C module is for internal use mostly from application frameworks like C, C, etc. =cut package NetSDS::Logger; use 5.8.0; use warnings; use Unix::Syslog qw(:macros :subs); use version; our $VERSION = '1.301'; #=============================================================================== =head1 CLASS API =over =item B - constructor Constructor B creates new logger object and opens socket with default NetSDS logging parameters. Arguments allowed (as hash): B - application name for identification Use only ASCII characters in "name" to avoid possible errors. Default value is "NetSDS". B - logging facility Available facility values: * local0..local7 * user * daemon If not set 'local0' is used as default value =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; my $self = {}; # Set application identification name my $name = 'NetSDS'; if ( $params{name} ) { $name = $params{name}; } # Set logging facility my %facility_map = ( 'local0' => LOG_LOCAL0, 'local1' => LOG_LOCAL1, 'local2' => LOG_LOCAL2, 'local3' => LOG_LOCAL3, 'local4' => LOG_LOCAL4, 'local5' => LOG_LOCAL5, 'local6' => LOG_LOCAL6, 'local7' => LOG_LOCAL7, 'user' => LOG_USER, 'daemon' => LOG_DAEMON, ); my $facility = LOG_LOCAL0; # default is local0 if ( $params{facility} ) { $facility = $facility_map{ $params{facility} } || LOG_LOCAL0; } openlog( $name, LOG_PID | LOG_CONS | LOG_NDELAY, $facility ); return bless $self, $class; } ## end sub new #*********************************************************************** =item B - write record to log Wrapper to C method of L module. Level is passed as string and may be one of the following: alert - LOG_ALERT crit - LOG_CRIT debug - LOG_DEBUG emerg - LOG_EMERG error - LOG_ERR info - LOG_INFO notice - LOG_NOTICE warning - LOG_WARNING =cut #----------------------------------------------------------------------- sub log { my ( $self, $level, $message ) = @_; # Level aliases my %LEVFIX = ( alert => LOG_ALERT, crit => LOG_CRIT, critical => LOG_CRIT, deb => LOG_DEBUG, debug => LOG_DEBUG, emerg => LOG_EMERG, emergency => LOG_EMERG, panic => LOG_EMERG, err => LOG_ERR, error => LOG_ERR, inf => LOG_INFO, info => LOG_INFO, inform => LOG_INFO, note => LOG_NOTICE, notice => LOG_NOTICE, warning => LOG_WARNING, warn => LOG_WARNING, ); my $LEV = $LEVFIX{$level}; if ( !$LEV ) { $LEV = LOG_INFO; } if ( !$message ) { $message = ""; } syslog( $LEV, "[$level] $message" ); } ## end sub log #*********************************************************************** =item B - class destructor Destructor (DESTROY method) calls C function. That's all. =cut #----------------------------------------------------------------------- sub DESTROY { closelog(); } 1; __END__ =back =head1 EXAMPLES See L for example. =head1 SEE ALSO L =head1 TODO 1. Implement logging via UDP socket. =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/App/0000755000076400007640000000000011277046434014210 5ustar mishamishaNetSDS-1.301/lib/NetSDS/App/FCGI.pm0000444000076400007640000003064011276226752015261 0ustar mishamisha#=============================================================================== # # FILE: FCGI.pm # # DESCRIPTION: Common FastCGI applications framework # # NOTES: This fr # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 15.07.2008 16:54:45 EEST #=============================================================================== =head1 NAME NetSDS::App::FCGI - FastCGI applications superclass =head1 SYNOPSIS # Run application MyFCGI->run(); 1; # Application package itself package MyFCGI; use base 'NetSDS::App::FCGI'; sub process { my ($self) = @_; $self->data('Hello World'); $self->mime('text/plain'); $self->charset('utf-8'); } =head1 DESCRIPTION C module contains superclass for FastCGI applications. This class is based on C module and inherits all its functionality like logging, configuration processing, etc. =cut package NetSDS::App::FCGI; use 5.8.0; use strict; use warnings; use base 'NetSDS::App'; use CGI::Fast; use CGI::Cookie; use version; our $VERSION = '1.301'; #*********************************************************************** =head1 CLASS API =over =item B - class constructor Normally constructor of application framework shouldn't be invoked directly. =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; my $self = $class->SUPER::new( cgi => undef, mime => undef, charset => undef, data => undef, redirect => undef, cookie => undef, status => undef, headers => {}, %params, ); return $self; } #*********************************************************************** =item B - accessor to CGI.pm request handler my $https_header = $self->cgi->https('X-Some-Header'); =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('cgi'); #*********************************************************************** =item B - set response HTTP status Paramters: new status to set Returns: response status value $self->status('200 OK'); =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('status'); #*********************************************************************** =item B - set response MIME type Paramters: new MIME type for response $self->mime('text/xml'); # output will be XML data =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('mime'); #*********************************************************************** =item B - set response character set if necessary $self->mime('text/plain'); $self->charset('koi8-r'); # ouput as KOI8-R text =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('charset'); #*********************************************************************** =item B - set response data Paramters: new data "as is" $self->mime('text/plain'); $self->data('Hello world!'); =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('data'); #*********************************************************************** =item B - send HTTP redirect Paramters: new URL (relative or absolute) This method send reponse with 302 status and new location. if (havent_data()) { $self->redirect('http://www.google.com'); # to google! }; =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('redirect'); #*********************************************************************** =item B - Paramters: Returns: This method provides..... =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('cookie'); #*********************************************************************** =item B - set/get response HTTP headers Paramters: new headers as hash reference $self->headers({ 'X-Beer' => 'Guiness', ); =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('headers'); #*********************************************************************** =item B - main FastCGI loop Paramters: none This method implements common FastCGI (or CGI) loop. =cut #----------------------------------------------------------------------- sub main_loop { my ($self) = @_; $self->start(); $SIG{TERM} = undef; $SIG{INT} = undef; # Switch of verbosity $self->{verbose} = undef; # Enter FastCGI loop while ( $self->cgi( CGI::Fast->new() ) ) { # Retrieve request cookies $self->_set_req_cookies(); # Set default response parameters $self->mime('text/plain'); # plain text output $self->charset('utf-8'); # UTF-8 charset $self->data(''); # empty string response $self->status("200 OK"); # everything OK $self->cookie( [] ); # no cookies $self->redirect(undef); # no redirects # Call request processing method $self->process(); # Send 302 and Location: header if redirect if ( $self->redirect ) { print $self->cgi->header( -cookie => $self->cookie, -status => '302 Moved', 'Location' => $self->redirect ); } else { # Implement generic content output use bytes; print $self->cgi->header( -type => $self->mime, -status => $self->status, -charset => $self->charset, -cookie => $self->cookie, -Content_length => bytes::length( $self->data ), %{ $self->headers }, ); no bytes; # Send return data to client if ( $self->data ) { $| = 1; # set autoflushing mode to avoid output buffering binmode STDOUT; print $self->data; } } ## end else [ if ( $self->redirect ) } ## end while ( $self->cgi( CGI::Fast... # Call finalization hooks $self->stop(); } ## end sub main_loop #*********************************************************************** =item B - set cookie Paramters: hash (name, value, expires) $self->set_cookie(name => 'sessid', value => '343q5642653476', expires => '+1h'); =cut #----------------------------------------------------------------------- sub set_cookie { my ( $self, %par ) = @_; push @{ $self->{cookie} }, $self->cgi->cookie( -name => $par{name}, -value => $par{value}, -expires => $par{expires} ); } #*********************************************************************** =item B - get cookie by name Paramters: cookie name Returns cookie value by it's name my $sess = $self->get_cookie('sessid'); =cut #----------------------------------------------------------------------- sub get_cookie { my ( $self, $name ) = @_; return $self->{req_cookies}->{$name}->{value}; } #*********************************************************************** =item B - CGI request parameter Paramters: CGI parameter name Returns: CGI parameter value This method returns CGI parameter value by it's name. my $cost = $self->param('cost'); =cut #----------------------------------------------------------------------- sub param { my ( $self, @par ) = @_; return $self->cgi->param(@par); } #*********************************************************************** =item B - CGI request parameter Paramters: URL parameter name Returns: URL parameter value This method works similar to B method, but returns only parameters from the query string. my $action = $self->url_param('a'); =cut #----------------------------------------------------------------------- sub url_param { my ( $self, @par ) = @_; return $self->cgi->url_param(@par); } #*********************************************************************** =item B - request HTTP header Paramters: request header name Returns: header value This method returns HTTP request header value by name. my $beer = $self->http('X-Beer'); =cut #----------------------------------------------------------------------- sub http { my $self = shift; my $par = shift; return $self->cgi->http($par); } #*********************************************************************** =item B - request HTTPS header This method returns HTTPS request header value by name and is almost the same as http() method except of it works with SSL requests. my $beer = $self->https('X-Beer'); =cut #----------------------------------------------------------------------- sub https { my $self = shift; my $par = shift; return $self->cgi->https($par); } #*********************************************************************** =item B - get raw cookie data Just proxying C method from CGI.pm =cut #----------------------------------------------------------------------- sub raw_cookie { my ($self) = @_; return $self->cgi->raw_cookie; } #************************************************************************** =item B - User-Agent request header my $ua_info = $self->user_agent(); =cut #----------------------------------------------------------------------- sub user_agent { my ($self) = @_; return $self->cgi->user_agent; } #*********************************************************************** =item B - HTTP request method if ($self->request_method eq 'POST') { $self->log("info", "Something POST'ed from client"); } =cut #----------------------------------------------------------------------- sub request_method { my ($self) = @_; return $self->cgi->request_method; } #*********************************************************************** =item B - CGI script name Returns: script name from CGI.pm =cut #----------------------------------------------------------------------- sub script_name { my ($self) = @_; return $self->cgi->script_name(); } #*********************************************************************** =item B - get PATH_INFO value if ($self->path_info eq '/help') { $self->data('Help yourself'); } =cut #----------------------------------------------------------------------- sub path_info { my ($self) = @_; return $self->cgi->path_info(); } #*********************************************************************** =item B - remote (client) host name warn "Client from: " . $self->remote_host(); =cut #----------------------------------------------------------------------- sub remote_host { my ($self) = @_; return $self->cgi->remote_host(); } #*********************************************************************** =item B - remote (client) IP address Returns: IP address of client from REMOTE_ADDR environment if ($self->remote_addr eq '10.0.0.1') { $self->data('Welcome people from our gateway!'); } =cut #----------------------------------------------------------------------- sub remote_addr { my ($self) = @_; return $ENV{REMOTE_ADDR}; } #*********************************************************************** =item B<_set_req_cookies()> - fetching request cookies (internal method) Fetching cookies from HTTP request to object C variable. =cut #----------------------------------------------------------------------- sub _set_req_cookies { my ($self) = @_; my %cookies = CGI::Cookie->fetch(); $self->{req_cookies} = \%cookies; return 1; } 1; __END__ =back =head1 EXAMPLES See C catalog for more example code. =head1 SEE ALSO L, L, L =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/App/SMTPD.pm0000444000076400007640000001340511276226752015440 0ustar mishamishapackage NetSDS::App::SMTPD; use 5.8.0; use strict; use warnings; package NetSDS::App::SMTPD::Socket; use IO::Socket; use base 'NetSDS::App'; use version; our $VERSION = '1.301'; sub new { my ( $proto, %args ) = @_; my $class = ref $proto || $proto; my $self = ( %args ? $class->SUPER::new(%args) : bless {}, $class ); return $self->create_socket( $args{'port'} ); } sub create_socket { my $self = shift; my $socket = IO::Socket->new; $socket->socket( PF_INET, SOCK_STREAM, scalar getprotobyname('tcp') ); $socket->blocking(0); $self->{'_socket'} = $socket; return $self; } sub get_socket_handle { +shift->{'_socket'} } sub close { +shift->get_socket_handle->close } package NetSDS::App::SMTPD::Client; use Net::Server::Mail::SMTP; use base 'NetSDS::App::SMTPD::Socket'; sub set_smtp { my $self = shift; $self->{'ip'} = shift; $self->{'_smtp'} = Net::Server::Mail::SMTP->new( socket => $self->get_socket_handle ); return $self; } sub set_callback { +shift->get_smtp->set_callback(@_) } sub process { +shift->get_smtp->process(@_) } sub get_smtp { +shift->{'_smtp'} } sub get_header { $_[0]->{'headers'}{ lc $_[1] } } sub get_msg { +shift->{'msg'} } sub get_ip { +shift->{'ip'} } sub get_mail { my ( $self, $data ) = @_; my @lines = split /\r\n(?! )/, $$data; $self->{'headers'} = {}; my $i; for ( $i = 0 ; $lines[$i] ; $i++ ) { my ( $key, $value ) = split /:\s*/, $lines[$i], 2; $key = lc $key; if ( exists $self->{'headers'}{$key} ) { unless ( ref $self->{'headers'}{$key} ) { my $temp = $self->{'headers'}{$key}; $self->{'headers'}{$key} = [ $temp, $value ]; } else { push @{ $self->{'headers'}{$key} }, $value; } } else { $self->{'headers'}{$key} = $value; #TODO fix me could be several Received } } $self->{'msg'} = join "\r\n", @lines[ $i + 1 .. $#lines ]; return 1; } ## end sub get_mail package NetSDS::App::SMTPD; use base 'NetSDS::App::SMTPD::Socket'; use IO::Socket; sub create_socket { my ( $self, $port ) = @_; $port ||= 2525; return unless $port; $self->SUPER::create_socket; setsockopt( $self->get_socket_handle, SOL_SOCKET, SO_REUSEADDR, 1 ); bind( $self->get_socket_handle, sockaddr_in( $port, INADDR_ANY ) ) or die "Can't use port $port"; listen( $self->get_socket_handle, SOMAXCONN ) or die "Can't listen on port: $port"; return $self; } sub can_read { my $self = shift; my $rin = ''; vec( $rin, fileno( $self->get_socket_handle ), 1 ) = 1; return select( $rin, undef, undef, undef ); } sub accept { my $self = shift; $self->can_read; my $client = NetSDS::App::SMTPD::Client->new; my $peer = accept( $client->get_socket_handle, $self->get_socket_handle ); if ($peer) { $client->set_smtp( inet_ntoa( ( sockaddr_in($peer) )[1] ) ); $self->speak( "connection from ip [" . $client->get_ip . "]" ); $client->set_callback( DATA => \&data, $client ); return $client; } } sub data { my ( $smtp, $data ) = @_; return $smtp->{'_context'}->get_mail($data); } sub process { my $self = shift; my $client = $self->accept; return unless $client; $client->process; $client->close; $self->speak( "connection from ip [" . $client->get_ip . "] closed" ); return $client; } 1; __END__ =head1 NAME NetSDS::App::SMTPD =head1 SYNOPSIS use NetSDS::App::SMTPD =head1 Packages =head1 NetSDS::App::SMTPD::Socket Needs for work with socket. This module is a parent for NetSDS::App::SMTPD and NetSDS::App::SMTPD::Client and a child of a NetSDS::APP =head3 ITEMS =over 8 =item B Creating a simple socket which could be transformed into a listening in NetSDS::App::SMTPD and could be used in NetSDS::App::SMTPD::Client for accept connection =item B This method uses for making a timeout before connections to the server: if there is no connections to accept, program would be just waiting in select while the connection appeared. =item B Close socket =back =head1 NetSDS::App::SMTPD::Client Provides the smtp protocol bu using Net::Server::Mail::SMTP. Had attributes: smtp - an object of Net::Server::Mail::SMTP, ip - ip of the remote host, headers - ref hash with headers of a message, msg - a body of a message. =head3 ITEMS =over 8 =item B and B All that subs do - its only call the methods of a Net::Server::Mail::SMTP with the same name. =item B In this sub we parse message and set headers of the object and message body. This sub is call as a callback on event DATA =item B and B Get methods that make you access to a header of a msg and message body. Example: $client->get_header('FROM') or $client->get_header('to'); =back =head1 NetSDS::App::SMTPD This module init a smtp-server. =head3 ITEMS =over 8 =item B Init a listening socket by creating a simple socket Super::create_socket and make it listening. =item B Takes - a message that has been received, parses them and prepare the structure of headers, body for next actions =item B Waiting for an smtp connection and that accept it. =item B =item B =back =head1 Example #!/usr/bin/env perl use strict; use warnings; Receiver->run( infinite => 1, debug => 1, verbose => 1, conf_file => '../conf/mts-receiver.conf', ); 1; package Receiver; use base 'NetSDS::App::SMTPD'; sub process { my $self = shift; my $client = $self->SUPER::process; #do something with msg; my $from = $client->get_header('from'); my $msg = $client->get_msg; ..... return $self; }; or you could reinit process like this: sub process { my $self = shift; my $client = $self->accept; return unless $client; $client->process; #do something ...... $client->close; return $self; }; =head1 AUTHOR Yana Kornienko =cut NetSDS-1.301/lib/NetSDS/App/JSRPC.pm0000444000076400007640000002364711276226752015443 0ustar mishamisha#=============================================================================== # # FILE: JSRPC.pm # # DESCRIPTION: NetSDS admin # # NOTES: --- # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 10.08.2009 20:57:57 EEST #=============================================================================== =head1 NAME NetSDS::App::JSRPC - JSON-RPC server framework =head1 SYNOPSIS #!/usr/bin/env perl # JSON-RPC server use 5.8.0; use warnings; use strict; JServer->run(); 1; # Server application logic package JServer; use base 'NetSDS::App::JSRPC'; # This method is available via JSON-RPC sub sum { my ($self, $param) = @_; return $$param[0] + $$param[1]; } 1; =head1 DESCRIPTION C module implements framework for common JSON-RPC based server application. JSON-RPC is a HTTP based protocol providing remote procudure call (RPC) functionality using JSON for requests and responses incapsulation. This implementation is based on L module and expected to be executed as FastCGI or CGI application. Diagram of class inheritance: [NetSDS::App::JSRPC] - JSON-RPC server | [NetSDS::App::FCGI] - CGI/FCGI application | [NetSDS::App] - common application | [NetSDS::Class::Abstract] - abstract class Both request and response are JSON-encoded strings represented in HTTP protocol as data of 'application/json' MIME type. =head1 APPLICATION DEVELOPMENT To develop new JSON-RPC server application you need to create application class inherited from C: It's just empty application: #!/usr/bin/env perl JSApp->run( conf_file => '/etc/NetSDS/jsonapp.conf' ); package JSApp; use base 'NetSDS::App::JSRPC'; 1; Alsoe you may want to add some specific code for application startup: sub start { my ($self) = @_; connect_to_dbms(); query_for_external_startup_config(); do_other_initialization(); } And of course you need to add methods providing necessary functions: sub send_sms { my ($self, $params) = @_; return $self->{kannel}->send( from => $params{'from'}, to => $params{'to'}, text => $params{'text'}, ); } sub kill_smsc { my ($self, $params) = @_; # 1M of MT SM should be enough to kill SMSC! # Otherwise we call it unbreakable :-) for (my $i=1; $<100000000; $i++) { $self->{kannel}->send( %mt_sm_parameters, ); } if (smsc_still_alive()) { return $self->error("Can't kill SMSC! Need more power!"); } } =head1 ADVANCED FUNCTIONALITY C module provides two methods that may be used to implement more complex logic than average RPC to one class. =over =item B - method availability checking By default it is just wrapper around C function. However it may be rewritten to check for methods in other classes or even construct necessary methods on the fly. =item B - method dispatching By default it just call local class method with the same name as in JSON-RPC call. Of course it can be overwritten and process query in some other way. =back This code describes logic of call processing: # It's not real code if (can_method($json_method)) { process_call($json_method, $json_params); } For more details read documentation below. =cut package NetSDS::App::JSRPC; use 5.8.0; use strict; use warnings; use JSON; use base 'NetSDS::App::FCGI'; use version; our $VERSION = '1.301'; #=============================================================================== =head1 CLASS API =over =item B - class constructor It's internally used constructor that shouldn't be used from application directly. =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; my $self = $class->SUPER::new(%params); return $self; } #*********************************************************************** =item B - main JSON-RPC iteration This is internal method that implements JSON-RPC call processing. =cut #----------------------------------------------------------------------- sub process { my ($self) = @_; # TODO - implement request validation # Parse JSON-RPC2 request my $http_request = $self->param('POSTDATA'); # Set response MIME type $self->mime('application/json'); # Parse JSON-RPC call if ( my ( $js_method, $js_params, $js_id ) = $self->_request_parse($http_request) ) { # Try to call method if ( $self->can_method($js_method) ) { # Call method and hope it will give some response my $result = $self->process_call( $js_method, $js_params ); if ( defined($result) ) { # Make positive response $self->data( $self->_make_result( result => $result, id => $js_id ) ); } else { # Can't get positive result $self->data( $self->_make_error( code => -32000, message => $self->errstr || "Error response from method $js_method", id => undef, ) ); } } else { # Can't find proper method $self->data( $self->_make_error( code => -32601, message => "Can't find JSON-RPC method", id => undef, ) ); } } else { # Send error object as a response $self->data( $self->_make_error( code => -32700, message => "Can't parse JSON-RPC call", id => undef, ) ); } } ## end sub process #*********************************************************************** =item B - check method availability This method allows to check if some method is available for execution. By default it use C but may be rewritten to implement more complex calls dispatcher. Paramters: method name (string) Return true if method execution allowed, false otherwise. Example: # Rewrite can_method() to search in other class sub can_method { my ($self, $method) = @_; return Other::Class->can($method); } =cut #----------------------------------------------------------------------- sub can_method { my ($self, $method) = @_; return $self->can($method); } #*********************************************************************** =item B - execute method call Paramters: method name, parameters. Returns parameters from executed method as is. Example: # Rewrite process_call() to use other class sub process_call { my ( $self, $method, $params ) = @_; return Other::Class->$method($params); } =cut #----------------------------------------------------------------------- sub process_call { my ( $self, $method, $params ) = @_; return $self->$method($params); } #*********************************************************************** =item B<_request_parse($post_data)> - parse HTTP POST Paramters: HTTP POST data as string Returns: request method, parameters, id =cut #----------------------------------------------------------------------- sub _request_parse { my ( $self, $post_data ) = @_; my $js_request = eval { decode_json($post_data) }; return $self->error("Can't parse JSON data") if $@; return ( $js_request->{'method'}, $js_request->{'params'}, $js_request->{'id'} ); } #*********************************************************************** =item B<_make_result(%params)> - prepare positive response This is internal method for encoding JSON-RPC response string. Paramters: =over =item B - the same as request Id (see specification) =item B - method result =back Returns JSON encoded response message. =cut #----------------------------------------------------------------------- sub _make_result { my ( $self, %params ) = @_; # Prepare positive response return encode_json( { jsonrpc => '2.0', id => $params{'id'}, result => $params{'result'}, } ); } #*********************************************************************** =item B<_make_error(%params)> - prepare error response Internal method implementing JSON-RPC error response. Paramters: =over =item B - the same as request Id (see specification) =item B - error code (default is -32603, internal error) =item B - error message =back Returns JSON encoded error message =cut #----------------------------------------------------------------------- sub _make_error { my ( $self, %params ) = @_; # Prepare error code and message # http://groups.google.com/group/json-rpc/web/json-rpc-1-2-proposal my $err_code = $params{code} || -32603; # Internal JSON-RPC error. my $err_msg = $params{message} || "Internal error."; # Return JSON encoded error object return encode_json( { jsonrpc => '2.0', id => $params{'id'}, error => { code => $err_code, message => $err_msg, }, } ); } ## end sub _make_error 1; __END__ =back =head1 EXAMPLES See C appliction. =head1 SEE ALSO L L L - JSON-RPC 1.0 L - JSON-RPC 2.0 =head1 TODO 1. Move error codes to constants to provide more clear code. 2. Implement objects/classes support. =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/Class/0000755000076400007640000000000011277046434014535 5ustar mishamishaNetSDS-1.301/lib/NetSDS/Class/Abstract.pm0000444000076400007640000001666611276226752016655 0ustar mishamisha#=============================================================================== # # FILE: Abstract.pm # # DESCRIPTION: Abstract Class for other NetSDS code # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 24.04.2008 11:42:42 EEST #=============================================================================== =head1 NAME NetSDS::Class::Abstract - superclass for all NetSDS APIs =head1 SYNOPSIS package MyClass; use base 'NetSDS::Class::Abstract'; __PACKAGE__->mk_accessors(qw/my_field/); sub error_sub { my ($self) = @_; if (!$self->my_field) { return $self->error("No my_field defined"); } } 1; =head1 DESCRIPTION C is a superclass for all other NetSDS classes, containing the following functionality: =over =item * common class constructor =item * safe modules inclusion =item * class and objects accessors =item * logging =item * error handling; =back All other class/object APIs should inherit this class to use it's functionality in standard way. =cut package NetSDS::Class::Abstract; use 5.8.0; use strict; use warnings; use base qw( Class::Accessor::Class ); # Error handling class variables our $_ERRSTR; # error string our $_ERRCODE; # error code use Data::Structure::Util; # unblessing objects use version; our $VERSION = '1.301'; #*********************************************************************** =head1 CONSTRUCTOR, INITIALIZATION, APPLICATION =over =item B - common constructor C method implements common constructor for NetSDS classes. Constructor may be overwriten in inherited classes and usually this happens to implement module specific functionality. Constructor requres parameters as hash that are set as object properties. my $object = NetSDS::SomeClass->new( foo => 'abc', bar => 'def', ); =cut #----------------------------------------------------------------------- sub new { my ( $proto, %params ) = @_; my $class = ref($proto) || $proto; my $self = \%params; bless( $self, $class ); return $self; } #*********************************************************************** =item B - class properties accessor See L for details. __PACKAGE__->mk_class_accessors('foo', 'bar'); =item B - object properties accessors See L for details. $self->mk_accessors('foo', 'bar'); Other C methods available as well. =cut #----------------------------------------------------------------------- #*********************************************************************** =item B - load modules on demand C provides safe on demand modules loader. It requires list of modules names as parameters Return 1 in case of success or C if faied. Error messages in case of failure are available using C call. Example: # Load modules for daemonization if ($daemon_mode) { $self->use_modules("Proc::Daemon", "Proc::PID::File"); } =cut #----------------------------------------------------------------------- sub use_modules { my $self = shift(@_); foreach my $mod (@_) { eval "use $mod;"; if ($@) { return $self->error($@); } } return 1; } #*********************************************************************** =item B - return unblessed object Return unblessed data structure of object that may be used when some code requires non blessed structures (like JSON serialization). Example: my $var = $obj->unbless(); =cut #----------------------------------------------------------------------- sub unbless { my ($self) = @_; return Data::Structure::Util::unbless($self); } #*********************************************************************** =back =head1 LOGGING =over =item B - get/set logging handler C property is an object that should provide functionality handling log messaging. Usually it's object of L class or C. However it may another object implementing non-standard features like sending log to e-mail or to DBMS. Example: # Set logger and send log message $obj->logger(NetSDS::Logger->new()); $obj->log("info", "Logger connected"); =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('logger'); # Logger #*********************************************************************** =item B - write log message Paramters: log level, log message $obj->log("info", "We still alive"); =cut #----------------------------------------------------------------------- sub log { my ( $self, $level, $msg ) = @_; # Logger expected to provide "log()" method if ( $self->logger() and $self->logger()->can('log') ) { $self->logger->log( $level, $msg ); } else { warn "[$level] $msg\n"; } } #*********************************************************************** =back =head1 ERROR HANDLING =over =item B - set error message and code C method set error message and optional error code. It can be invoked in both class and object contexts. Example 1: set class error NetSDS::Foo->error("Mistake found"); Example 2: set object error with code $obj->error("Can't launch rocket", BUG_STUPID); =cut #----------------------------------------------------------------------- sub error { my ( $self, $msg, $code ) = @_; $msg ||= ''; # error message $code ||= ''; # error code if ( ref($self) ) { $self->{_errstr} = $msg; $self->{_errcode} = $code; } else { $_ERRSTR = $msg; $_ERRCODE = $code; } return undef; } #*********************************************************************** =item B - retrieve error message C method returns error string in both object and class contexts. Example: warn "We have an error: " . $obj->errstr; =cut #----------------------------------------------------------------------- sub errstr { my $self = shift; return ref($self) ? $self->{_errstr} : $_ERRSTR; } #*********************************************************************** =item B - retrieve error code C method returns error code in both object and class contexts. Example: if ($obj->errcode == 42) { print "Epic fail! We've found an answer!"; } =cut #----------------------------------------------------------------------- sub errcode { my $self = shift; return ref($self) ? $self->{_errcode} : $_ERRCODE; } 1; __END__ =back =head1 EXAMPLES See C directory and other C moduleis for examples of code. =head1 SEE ALSO L =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/Feature.pm0000444000076400007640000001054111276776160015425 0ustar mishamisha#=============================================================================== # # FILE: Feature.pm # # DESCRIPTION: Abstract application feature class. # # NOTES: --- # AUTHOR: Michael Bochkaryov (RATTLER), # COMPANY: Net.Style # CREATED: 14.09.2008 12:32:03 EEST #=============================================================================== =head1 NAME NetSDS::Feature - abstract application feature =head1 SYNOPSIS package NetSDS::Feature::DBI; use DBI; use base 'NetSDS::Feature'; sub init { my ($self) = @_; my $dsn = $self->conf->{dsn}; my $user = $self->conf->{user}; my $passwd = $self->conf->{passwd}; $self->{dbconn} = DBI->connect($dsn, $user, $passwd); } # Sample method - DBI::do proxy sub do { my $self = shift @_; return $self->{dbconn}->do(@_); } 1; =head1 DESCRIPTION Application C are Perl5 packages with unified API for easy integration of some functionality into NetSDS applications infrastructure. C module contains superclass for application features providing the following common feature functionality: * class construction * initialization stub * logging =cut package NetSDS::Feature; use 5.8.0; use strict; use warnings; use base qw(Class::Accessor Class::ErrorHandler); use version; our $VERSION = '1.301'; #=============================================================================== =head1 CLASS METHODS =over =item B - feature constructor =cut #----------------------------------------------------------------------- sub create { my ( $class, $app, $conf ) = @_; my $self = { app => $app, conf => $conf, }; bless $self, $class; # Module specific initialization $self->init(); return $self; } #*********************************************************************** =item B - feature initialization This method should be rewritten with feature functionality implementation. It's possibly to use application and configuration handlers at this time. Example: sub init { my ($self) = @_; $self->{answer} = $self->conf->{answer} || '42'; my $pid = $self->app->pid(); if ($self->app->daemon()) { $self->log("info", "Seems we are in a daemon mode"); } } =cut #----------------------------------------------------------------------- sub init { my ($self) = @_; } #*********************************************************************** =back =head1 OBJECT METHODS =over =item B - application object This method allows to use application methods and properties. print "Feature included from app: " . $self->app->name; =cut #----------------------------------------------------------------------- __PACKAGE__->mk_ro_accessors('app'); #*********************************************************************** =item B - feature configuration This method provides access to feature configuration. =cut #----------------------------------------------------------------------- __PACKAGE__->mk_ro_accessors('conf'); #*********************************************************************** =item B - implements logging Example: # Write log message $self->log("info", "Application does something interesting."); See L documentation for details. =cut #----------------------------------------------------------------------- sub log { my ($self) = shift @_; return $self->app->log(@_); } 1; __END__ =back =head1 EXAMPLES See C script. =head1 SEE ALSO =over =item * L =back =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/Const.pm0000444000076400007640000000552711276226752015125 0ustar mishamisha#=============================================================================== # # FILE: Const.pm # # DESCRIPTION: NetSDS common constants # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 05.05.2008 16:40:51 EEST #=============================================================================== =head1 NAME NetSDS::Const - common NetSDS constants =head1 SYNOPSIS use NetSDS::Const; print "XML encoding is " . XML_ENCODING; print "Week contains " . INTERVAL_WEEK . " seconds"; =head1 DESCRIPTION This module provides most common constants like default encoding and language, time intervals, etc. =cut package NetSDS::Const; use 5.8.0; use strict; use warnings; use base 'Exporter'; use version; our $VERSION = '1.301'; our @EXPORT = qw( LANG_BE LANG_DE LANG_EN LANG_RU LANG_UK DEFAULT_ENCODING DEFAULT_LANG XML_VERSION XML_ENCODING INTERVAL_MINUTE INTERVAL_HOUR INTERVAL_DAY INTERVAL_WEEK ); =head1 LANGUAGE AND ENCODINGS =over =item B - C =item B - C =item B - C =item B - C =item B - C =item B - C in current version =item B - C =back =cut use constant LANG_BE => 'be'; use constant LANG_DE => 'de'; use constant LANG_EN => 'en'; use constant LANG_RU => 'ru'; use constant LANG_UK => 'uk'; use constant DEFAULT_LANG => LANG_RU; use constant DEFAULT_ENCODING => 'UTF8'; =head1 XML CONSTANTS =over =item B - C<1.0> =item B - C =back =cut use constant XML_VERSION => '1.0'; use constant XML_ENCODING => 'UTF-8'; =head1 TIME INTERVALS =over =item B - 60 seconds =item B - 3600 seconds =item B - 86400 seconds =item B - 604800 seconds =back =cut use constant INTERVAL_MINUTE => 60; use constant INTERVAL_HOUR => 3600; use constant INTERVAL_DAY => 86400; use constant INTERVAL_WEEK => 604800; 1; __END__ =head1 AUTHOR Valentyn Solomko Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/Template.pm0000444000076400007640000001106311276226752015602 0ustar mishamisha#=============================================================================== # # FILE: Template.pm # # DESCRIPTION: Wrapper for HTML::Template::Pro # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 16.07.2008 23:30:12 EEST #=============================================================================== =head1 NAME NetSDS::Template - NetSDS template engine =head1 SYNOPSIS use NetSDS::Template; =head1 DESCRIPTION C class provides developers with ability to create template based web applications. =cut package NetSDS::Template; use 5.8.0; use strict; use warnings; use base 'NetSDS::Class::Abstract'; use HTML::Template::Pro; use NetSDS::Util::File; use version; our $VERSION = '1.301'; #=============================================================================== =head1 CLASS API =over =item B - class constructor This concstructor loads template files and parse them. my $tpl = NetSDS::Template->new( dir => '/etc/NetSDS/templates', esc => 'URL', include_path => '/mnt/floppy/templates', ); =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; # Get filenames of templates my $tpl_dir = $params{dir}; # Initialize templates hash reference my $tpl = {}; my @tpl_files = @{ dir_read( $tpl_dir, 'tmpl' ) }; # Add support for 'include_path' option foreach my $file (@tpl_files) { # Read file to memory if ( $file =~ /(^.*)\.tmpl$/ ) { # Determine template name and read file content my $tpl_name = $1; my $tpl_content = file_read("$tpl_dir/$file"); if ($tpl_content) { # Prepare include path list my $include_path = $params{include_path} ? $params{include_path} : undef; my @inc = (); if ( defined $include_path ) { push @inc, $include_path; } push @inc, ( $params{dir} . '/inc', '/usr/share/NetSDS/templates/' ); # Create template processing object my $tem = HTML::Template::Pro->new( scalarref => \$tpl_content, filter => $params{filter} || [], loop_context_vars => 1, global_vars => 1, default_escape => defined( $params{esc} ) ? $params{esc} : 'HTML', search_path_on_include => 1, path => \@inc, ); $tpl->{$tpl_name} = $tem; } ## end if ($tpl_content) } ## end if ( $file =~ /(^.*)\.tmpl$/) } ## end foreach my $file (@tpl_files) # Create myself at last :) return $class->SUPER::new( templates => $tpl ); } ## end sub new #*********************************************************************** =item B - render document by template and paramters This method prepares set of parameters and applies them to given template. Return is a ready for output document after processing. Example: # Simple template rendering with scalar parameters my $str = $tmp->render('main', title => 'Main Page'); # Rendering template with array parameters my $str2 = $tmp->render('list', title => 'Statistics', users => \@users_list); =cut #----------------------------------------------------------------------- sub render { my ( $self, $name, %params ) = @_; my $tpl = $self->{'templates'}->{$name}; unless ($tpl) { return $self->error("Wrong template name: '$name'"); } # Clear previously set paramters and change to new $tpl->clear_params(); $tpl->param(%params); # Return finally rendered document return $tpl->output; } 1; __END__ =back =head1 EXAMPLES None =head1 BUGS Unknown yet =head1 SEE ALSO L, L =head1 TODO 1. Add i18n support to process multilingual templates. =head1 AUTHOR Michael Bochkaryov =head1 THANKS Igor Vlasenko (http://search.cpan.org/~viy/) for HTML::Template::Pro =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/Conf.pm0000444000076400007640000000436411276226752014722 0ustar mishamisha#=============================================================================== # # FILE: Conf.pm # # DESCRIPTION: Configuration handling via command line and Config::General # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 16.05.2008 12:24:55 EEST #=============================================================================== =head1 NAME NetSDS::Conf - API to configuration files =head1 SYNOPSIS use NetSDS::Conf; my $cf = NetSDS::Conf->getconf($conf_file); my $val = $cf->{'parameter'}; =head1 DESCRIPTION B module is a wrapper to B handler for NetSDS configuration files. This package is for internal usage and is called from B or inherited modules and should be never used directly from applications. =cut package NetSDS::Conf; use 5.8.0; use strict; use warnings; use Config::General; use version; our $VERSION = '1.301'; #*********************************************************************** =over =item B - read parameters from configuration file Paramters: configuration file name Returns: cofiguration as hash reference This method tries to read configuration file and fill object properties with read values. NOTE: Parameters set from command line will not be overriden. =cut #----------------------------------------------------------------------- sub getconf { my ( $proto, $cf ) = @_; # Check if configuration file available for reading and read data if ( $cf and ( -f $cf ) and ( -r $cf ) ) { my $conf = Config::General->new( -ConfigFile => $cf, -AllowMultiOptions => 'yes', -UseApacheInclude => 'yes', -InterPolateVars => 'yes', -ConfigPath => [ $ENV{NETSDS_CONF_DIR}, '/etc/NetSDS' ], -IncludeRelative => 'yes', -IncludeGlob => 'yes', -UTF8 => 'yes', ); # Parse configuration file my %cf_hash = $conf->getall; return \%cf_hash; } else { return undef; } } ## end sub getconf 1; __END__ =back =head1 EXAMPLES =head1 BUGS Unknown =head1 SEE ALSO L, L, L =head1 TODO 1. Improve documentation. =head1 AUTHOR Michael Bochkaryov =cut NetSDS-1.301/lib/NetSDS/Translate.pm0000444000076400007640000000566411276226752015776 0ustar mishamisha#=============================================================================== # # FILE: Translate.pm # # DESCRIPTION: Gettext wrapper # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 03.08.2009 13:34:51 UTC #=============================================================================== =head1 NAME NetSDS::Translate - simple API to gettext =head1 SYNOPSIS use NetSDS::Translate; my $trans = NetSDS::Translate->new( lang => 'ru', domain => 'NetSDS-IVR', ); print $trans->translate("Detect CallerID"); =head1 DESCRIPTION C module provides API to gettext translation subsystem =cut package NetSDS::Translate; use 5.8.0; use strict; use warnings; use POSIX; use Locale::gettext; use NetSDS::Const; use base 'NetSDS::Class::Abstract'; use version; our $VERSION = '1.301'; #=============================================================================== # =head1 CLASS API =over =item B - class constructor my $trans = NetSDS::Translate->new( lang => 'ru', domain => 'NetSDS-IVR', ); =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; # FIXME - this should be configurable option my %locale = ( ru => 'ru_RU.UTF-8', en => 'en_US.UTF-8', ua => 'ua_UK.UTF-8', ); my $self = $class->SUPER::new( lang => DEFAULT_LANG, domain => 'NetSDS', %params, ); # Initialize proper locale setlocale( LC_MESSAGES, $locale{$self->{lang}} ); $self->{translator} = Locale::gettext->domain($self->{domain}); return $self; } #*********************************************************************** =item B - translate string Return translated string. print $trans->translate("All ok"); =cut #----------------------------------------------------------------------- sub translate { my ( $self, $str ) = @_; return $self->{translator}->get($str); } 1; __END__ =back =head1 TODO 1. Make configurable language to locale conversion in constructor. 2. Implement placeholders support provided by gettext. =head1 SEE ALSO L =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/App.pm0000444000076400007640000006221311276226752014552 0ustar mishamisha#=============================================================================== # # MODULE: NetSDS::App # # DESCRIPTION: Common NetSDS application framework # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # #=============================================================================== =head1 NAME B - common application superclass =head1 SYNOPSIS #!/usr/bin/env perl use 5.8.0; use warnings; use strict; MyApp->run( conf_file => '/etc/NetSDS/myapp.conf', # default place for config search daemon => 1, # run in daemon mode use_pidfile => 1, # write PID file to avoid double processing verbose => 0, # no verbosity ); 1; # Application logic here package MyApp; use base 'NetSDS::App'; # Startup hook sub start { my ($self) = @_; # Use configuration $self->{listen_port} = $self->conf->{listen_port}; # Use logging subsystem $self->log("info", "Application successfully started with PID=".$self->pid); } # Main processing hook sub process { my ($self) = @_; print "Hello!"; # Use verbose output $self->speak("Trying to be more verbose"); } =head1 DESCRIPTION C is a base class for NetSDS applications. It implements common functionality including the following: * initialization * configuration file processing * command line parameters processing * application workflow * daemonization * PID file processing * logging * event detail records writing * default signal handling New application should be inherited from C class directly or via child classes for more specific tasks like CGI, AGI, SMPP and other. Common application workflow is described on this diagram: App->run(%params) | initialize() | ---------- | | start() | | | process() --- main_loop() | | stop() | | | ---------- | finalize() When application is starting C method is invoked first. It provides common start time functionality like CLI parameters processing, daemonization, reading configuration. C method may be overwritten in more specific frameworks to change default behaviour of some application types. Then C method invoked to process main application logic. This method provides three redefinable hooks: C, C and C. Theese hooks should be overwritten to implement necessary logic. =over =item * B - start time hook =item * B - process iteration hook =item * B - finish time hook =back Depending on C flag main_loop() may call process() hook in infinite loop or only once. C workflow may be redefined in inherited framework to implement some other process flow logic. On the last step C method is invoked to make necessary finalization actions on framework level. =head1 STARTUP PARAMETERS Application class may be provided with a number of parameters that allows to manage application behaviour. For example it may be a configuration file, daemonization mode or debugging flag. Such parameters are passed to run() method as hash: MyApp->run( has_conf => 1, conf_file => '/etc/sample/file.conf', daemon => 1, use_pidfile => 1, ); =over =item * B - 1 if configuration file is required (default: yes) Mostly our applications requires configuration files but some of them doesn't require any configuration (e.g. small utilities, etc). Set C parameter to 0 to avoid search of configuration file. =item * B - default path to configuration file (default: autodetect) This parameter allows to set explicitly path to configuration file. By default it's determined from application name and is looking like C =item * B - application name (default: autodetect) This name is used for config and PID file names, logging. By default it's automatically detected by executable script name. =item * B - 1 for debugging flag (default: no) =item * B - 1 for daemon mode (default: no) =item * B - 1 for verbose mode (default: no) =item * B - 1 to use PID files (default: no) =item * B - path to PID files catalog (default: '/var/run/NetSDS') =item * B - 1 for auto features inclusion (default: no) This parameter should be set to 1 if you plan to use automatically plugged application features. Read C section below. =item * B - 1 for inifinite loop (default: yes) =item * B - EDR (event detail records) file name (default: undef) =back =head1 COMMAND LINE PARAMETERS Command line parameters may be passed to NetSDS application to override defaults. =over =item * B<--conf> - path to config file =item * B<--[no]debug> - set debug mode =item * B<--[no]daemon> - set daemon/foreground mode =item * B<--[no]verbose> - set verbosity mode =item * B<--name> - set application name =back These CLI options overrides C, C, C, C and C default parameters that are passed in run() method. Examples: # Debugging in foreground mode ./application --config=/etc/myapp.conf --nodaemon --debug # Set application name explicitly ./application --name=myapp =cut package NetSDS::App; use 5.8.0; use strict; use warnings; use base 'NetSDS::Class::Abstract'; use version; our $VERSION = '1.301'; use NetSDS::Logger; # API to syslog daemon use NetSDS::Conf; # Configuration file processor use NetSDS::EDR; # Module writing Event Detail Records use Proc::Daemon; # Daemonization use Proc::PID::File; # Managing PID files use Getopt::Long qw(:config auto_version auto_help pass_through); use POSIX; use Carp; #=============================================================================== # =head1 CLASS API =over =item B - class constructor Constructor is usually invoked from C class method. It creates application object and set its initial properties from oarameters passed as hash. Standard parameters are: * name - application name * debug - set to 1 for debugging * daemon - set to 1 for daemonization * verbose - set to 1 for more verbosity * use_pidfile - set to 1 for PID files processing * pid_dir - path to PID files catalog * conf_file - path to configuration file * has_conf - set to 1 if configuration file is necessary * auto_features - set to 1 for auto features inclusion * infinite - set to 1 for inifinite loop =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; my $self = $class->SUPER::new( name => undef, # application name pid => $$, # proccess PID debug => undef, # debug mode flag daemon => undef, # daemonize if 1 verbose => undef, # be more verbose if 1 use_pidfile => undef, # check PID file if 1 pid_dir => '/var/run/NetSDS', # PID files catalog (default is /var/run/NetSDS) conf_file => undef, # configuration file name conf => undef, # configuration data logger => undef, # logger object has_conf => 1, # is configuration file necessary auto_features => 0, # are automatic features allowed or not infinite => 1, # is infinite loop edr_file => undef, # path to EDR file %params, ); return $self; } ## end sub new #*********************************************************************** =item B - application launcher This method calls class constructor and then switch to C method. All method parameters are transparently passed to application constructor. #!/usr/bin/env perl use 5.8.0; use warnings; use strict; MyApp->run( conf_file => '/etc/myapp.conf', daemon => 1, use_pidfile => 1, ); 1; # ********************************** # Logic of application package MyApp; use base 'NetSDS::App'; 1; =cut #----------------------------------------------------------------------- sub run { my $class = shift(@_); # Create application instance if ( my $app = $class->new(@_) ) { # Framework initialization $app->initialize(); # Application workflow $app->main_loop(); # Framework finalization $app->finalize(); } else { carp "Can't start application"; return undef; } } ## end sub run #*********************************************************************** =item B - application name This method is an accessor to application name allowing to retrieve this or set new one. print "My name is " . $self->name; =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('name'); #*********************************************************************** =item B - PID of application process Read only access to process identifier (PID). print "My PID is " . $self->pid; =cut #----------------------------------------------------------------------- __PACKAGE__->mk_ro_accessors('pid'); #*********************************************************************** =item B - debugging flag This method provides an accessor to debugging flag. If application called with --debug option it will return TRUE value. if ($self->debug) { print "Debug info: " . $debug_data; } =cut #----------------------------------------------------------------------- __PACKAGE__->mk_ro_accessors('debug'); #*********************************************************************** =item B - verbosity flag This method provides an accessor to verbosity flag. It may be used to increase application verbosity level if necessary. if ($self->verbose) { print "I'm working!"; }; NOTE: This flag is is for normal operations. If you need implement debug output or other development/testing functionality - use debug() instead. =cut #----------------------------------------------------------------------- __PACKAGE__->mk_ro_accessors('verbose'); #*********************************************************************** =item B - accessor to logger This method is accessor to logger (object of L class). NOTE: There is no need to use this method directly in application. See C method description to understand logging features. =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('logger'); #*********************************************************************** =item B - accessor to configuration This method is accessor to application configuration represented as hash reference returned by L module. Configuration sample: ------------------------ content_dir /var/lib/content send_url http://127.0.0.1:13013/ login netsds passwd topsecret ------------------------ Code sample: # Retrieve configuration my $content_dir = $self->conf->{content_dir}; my $kannel_url = $self->conf->{kannel}->{send_url}; =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('conf'); #*********************************************************************** =item B - PID file checking flag Paramters: TRUE if PID file checking required =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('use_pidfile'); #*********************************************************************** =item B - PID files storage Paramters: directory name $app->pid_dir("/var/run"); =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('pid_dir'); #*********************************************************************** =item B - daemonization flag Paramters: TRUE if application should be a daemon if ($self->daemon()) { $self->log("info", "Yeah! I'm daemon!"); }; =cut #----------------------------------------------------------------------- __PACKAGE__->mk_ro_accessors('daemon'); #*********************************************************************** =item B - auto features flag Automatic features inclusion allowed if TRUE. =cut #----------------------------------------------------------------------- __PACKAGE__->mk_ro_accessors('auto_features'); #*********************************************************************** =item B - is application in infinite loop Example: # Switch to infinite loop mode $app->infinite(1); =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('infinite'); #*********************************************************************** #*********************************************************************** =item B - accessor to EDR file name Paramters: EDR file path =cut #----------------------------------------------------------------------- __PACKAGE__->mk_accessors('edr_file'); #*********************************************************************** =item B Common application initialization: 1. Reading config if necessary. 2. Daemonize application. 3. Check PID file for already running application instances. 4. Start logger. 5. Prepare default signal handlers. =cut #----------------------------------------------------------------------- sub initialize { my ( $self, %params ) = @_; $self->speak("Initializing application."); # Determine application name from process name if ( !$self->{name} ) { $self->_determine_name(); } # Get CLI parameters $self->_get_cli_param(); # Daemonize, if needed if ( $self->daemon() ) { $self->speak("Daemonize, switch verbosity to false."); $self->{verbose} = undef; Proc::Daemon::Init; } # Update PID if necessary $self->{pid} = $$; # Create syslog handler if ( !$self->logger ) { $self->logger( NetSDS::Logger->new( name => $self->{name} ) ); $self->log( "info", "Logger started" ); } # Initialize EDR writer if ( $self->edr_file ) { $self->{edr_writer} = NetSDS::EDR->new( filename => $self->edr_file ); } # Process PID file if necessary if ( $self->use_pidfile() ) { if ( Proc::PID::File->running( dir => $self->pid_dir, name => $self->name ) ) { $self->log( "error", "Application already running, stop immediately!" ); die "Application already running, stop immediately!"; } } # Initialize configuration if ( $self->{has_conf} ) { # Automatically determine configuration file name if ( !$self->{conf_file} ) { $self->{conf_file} = $self->config_file( $self->{name} . ".conf" ); } # Get configuration file if ( my $conf = NetSDS::Conf->getconf( $self->{conf_file} ) ) { $self->conf($conf); $self->log( "info", "Configuration file read OK: " . $self->{conf_file} ); } else { $self->log( "error", "Can't read configuration file: " . $self->{conf_file} ); } # Add automatic features if ( $self->auto_features ) { $self->use_auto_features(); } } ## end if ( $self->{has_conf}) # Add signal handlers $SIG{INT} = sub { $self->speak("SIGINT caught"); $self->log( "warn", "SIGINT caught" ); $self->{to_finalize} = 1; }; $SIG{TERM} = sub { $self->speak("SIGTERM caught"); $self->log( "warn", "SIGTERM caught" ); $self->{to_finalize} = 1; }; } ## end sub initialize #*********************************************************************** =item B - add features to application This method implements automatic features inclusion by application configuration file (see C sections). =cut #----------------------------------------------------------------------- sub use_auto_features { my ($self) = @_; if ( !$self->auto_features ) { return $self->error("use_auto_features() called without setting auto_features property"); } # Check all sections in configuration if ( $self->conf and $self->conf->{feature} ) { my @features = ( keys %{ $self->conf->{feature} } ); foreach my $f (@features) { my $f_conf = $self->conf->{feature}->{$f}; my $class = $f_conf->{class}; # Really add feature object $self->add_feature( $f, $class, $f_conf ); } } } ## end sub use_auto_features #*********************************************************************** =item B - add feature Paramters: feature name, class name, parameters (optional) Returns: feature object $self->add_feature('kannel','NetSDS::Feature::Kannel', $self->conf->{feature}->{kannel}); $self->kannel->send(.....); =cut #----------------------------------------------------------------------- sub add_feature { my $self = shift @_; my $name = shift @_; my $class = shift @_; my $conf = shift @_; # Try to use necessary classes eval "use $class"; if ($@) { return $self->error( "Can't add feature module $class: " . $@ ); } # Feature class invocation eval { # Create feature instance $self->{$name} = $class->create( $self, $conf, @_ ); # Add logger $self->{$name}->{logger} = $self->logger; }; if ($@) { return $self->error( "Can't initialize feature module $class: " . $@ ); } # Create accessor to feature $self->mk_accessors($name); # Send verbose output $self->speak("Feature added: $name => $class"); # Write log message $self->log( "info", "Feature added: $name => $class" ); } ## end sub add_feature #*********************************************************************** =item B - switch to finalization stage This method called if we need to finish application. =cut #----------------------------------------------------------------------- sub finalize { my ( $self, $msg ) = @_; $self->log( 'info', 'Application stopped' ); exit(0); } #*********************************************************************** =item B - user defined initialization hook Abstract method for postinitialization procedures execution. Arguments and return defined in inherited classes. This method should be overwritten in exact application. Remember that start() methhod is invoked after initialize() =cut #----------------------------------------------------------------------- sub start { my ( $self, %params ) = @_; return 1; } #*********************************************************************** =item B - main loop iteration hook Abstract method for main loop iteration procedures execution. Arguments and return defined in inherited classes. This method should be overwritten in exact application. =cut #----------------------------------------------------------------------- sub process { my ( $self, %params ) = @_; return 1; } #*********************************************************************** =item B - post processing hook This method should be rewritten in target class to contain real post processing routines. =cut #----------------------------------------------------------------------- sub stop { my ( $self, %params ) = @_; return 1; } #*********************************************************************** =item B - main loop algorithm This method provide default main loop alghorythm implementation and may be rewritten for alternative logic. =back =cut #----------------------------------------------------------------------- sub main_loop { my ($self) = @_; # Run startup hooks my $ret = $self->start(); # Run processing hooks while ( !$self->{to_finalize} ) { # Call production code $ret = $self->process(); # Process infinite loop unless ( $self->{infinite} ) { $self->{to_finalize} = 1; } } # Run finalize hooks $ret = $self->stop(); } ## end sub main_loop #*********************************************************************** =head1 LOGGING AND ERROR HANDLING =over =item B - write message to log This method provides ablity to write log messages to syslog. Example: $self->log("info", "New message arrived with id=$msg_id"); =cut #----------------------------------------------------------------------- sub log { my ( $self, $level, $message ) = @_; # Try to use syslog handler if ( $self->logger() ) { $self->logger->log( $level, $message ); } else { # No syslog, send error to STDERR carp "[$level] $message"; } return undef; } ## sub log #*********************************************************************** =item B - return error with logging This method extends inherited method functionality with automatically logging this message to syslog. Example: if (!$dbh->ping) { return $self->error("We have problem with DBMS"); } =cut #----------------------------------------------------------------------- sub error { my ( $self, $message ) = @_; $self->log( "error", $message ); return $self->SUPER::error($message); } #*********************************************************************** =item B - verbose output Paramters: list of strings to be written as verbose output This method implements verbose output to STDOUT. $self->speak("Do something"); =cut #----------------------------------------------------------------------- sub speak { my ( $self, @params ) = @_; if ( $self->verbose ) { print join( "", @params ); print "\n"; } } #*********************************************************************** =item B - write EDR Paramters: list of EDR records to write $app->edr({ event => "call", status => "rejected", }); =cut #----------------------------------------------------------------------- sub edr { my ( $self, @records ) = @_; if ( $self->{edr_writer} ) { return $self->{edr_writer}->write(@records); } else { return $self->error("Can't write EDR to undefined destination"); } } #----------------------------------------------------------------------- #*********************************************************************** =item B - determine full configuration file name =cut #----------------------------------------------------------------------- sub config_file { my ( $self, $file_name ) = @_; my $conf_file; if ( $file_name =~ /^\// ) { $conf_file = $file_name; } else { # Try to find path by NETSDS_CONF_DIR environment my $file = ( $ENV{NETSDS_CONF_DIR} || "/etc/NetSDS/" ); $file =~ s/([^\/])$/$1\//; $conf_file = $file . $file_name; # Last resort - local folder (use for debug, not production) unless ( -f $conf_file && -r $conf_file ) { $conf_file = "./" . $file_name; } } return $conf_file; } ## end sub config_file # Determine application name from script name sub _determine_name { my ($self) = @_; # Dont override predefined name if ( $self->{name} ) { return $self->{name}; } $self->{name} = $0; # executable script $self->{name} =~ s/^.*\///; # remove directory path $self->{name} =~ s/\.(pl|cgi|fcgi)$//; # remove standard extensions } # Determine execution parameters from CLI sub _get_cli_param { my ($self) = @_; my $conf = undef; my $debug = undef; my $daemon = undef; my $verbose = undef; my $name = undef; # Get command line arguments GetOptions( 'conf=s' => \$conf, 'debug!' => \$debug, 'daemon!' => \$daemon, 'verbose!' => \$verbose, 'name=s' => \$name, ); # Set configuration file name if ($conf) { $self->{conf_file} = $conf; } # Set debug mode if ( defined $debug ) { $self->{debug} = $debug; } # Set daemon mode if ( defined $daemon ) { $self->{daemon} = $daemon; } # Set verbose mode if ( defined $verbose ) { $self->{verbose} = $verbose; } # Set application name if ( defined $name ) { $self->{name} = $name; } } ## end sub _get_cli_param 1; __END__ =back =head1 PLUGGABLE APPLICATION FEAUTURES To add more flexibility to application development C framework allows to add pluggable features. Application feature is a class dynamically loaded into application using configuration file parameters. To use application features developer should do the following: * set auto_features run() parameter * create C sections in application as described * create feature classes inherited from L =head1 EXAMPLES See samples/app.pl =head1 BUGS This module is a one bug itself :-) =head1 SEE ALSO L, L, L =head1 TODO Fix and cleanup! =head1 AUTHOR Valentyn Solomko Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/DBI.pm0000444000076400007640000002207411276226752014431 0ustar mishamisha#=============================================================================== # # FILE: DBI.pm # # DESCRIPTION: DBI wrapper for NetSDS # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 31.07.2009 13:56:33 UTC #=============================================================================== =head1 NAME NetSDS::DBI - DBI wrapper for NetSDS =head1 SYNOPSIS use NetSDS::DBI; $dbh = NetSDS::DBI->new( dsn => 'dbi:Pg:dbname=test;host=127.0.0.1;port=5432', login => 'user', passwd => 'topsecret', ); print $db->call("select md5(?)", 'zuka')->fetchrow_hashref->{md5}; =head1 DESCRIPTION C module provides wrapper around DBI module. =cut package NetSDS::DBI; use 5.8.0; use strict; use warnings; use DBI; use base 'NetSDS::Class::Abstract'; use version; our $VERSION = '1.301'; #=============================================================================== =head1 CLASS API =over =item B - class constructor $dbh = NetSDS::DBI->new( dsn => 'dbi:Pg:dbname=test;host=127.0.0.1;port=5432', login => 'user', passwd => 'topsecret', ); =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; # DBI handler attributes my $attrs = { $params{attrs} ? %{ $params{attrs} } : () }; # Startup SQL queries my $sets = $params{sets} || []; # Prepare additional parameters if ( $params{dsn} ) { # Parse DSN to determine DBD driver and provide my $dsn_scheme = undef; my $dsn_driver = undef; my $dsn_attr_str = undef; my $dsn_attrs = undef; my $dsn_dsn = undef; if ( ( $dsn_scheme, $dsn_driver, $dsn_attr_str, $dsn_attrs, $dsn_dsn ) = DBI->parse_dsn( $params{dsn} ) ) { # Set PostgreSQL default init queries if ( 'Pg' eq $dsn_driver ) { unshift( @{$sets}, "SET CLIENT_ENCODING TO 'UTF-8'" ); unshift( @{$sets}, "SET DATESTYLE TO 'ISO'" ); } # Set UTF-8 support $attrs = { %{$attrs}, pg_enable_utf8 => 1, }; } else { return $class->error( "Can't parse DBI DSN: " . $params{dsn} ); } } else { return $class->error("Can't initialize DBI connection without DSN"); } # initialize parent class my $self = $class->SUPER::new( dbh => undef, dsn => $params{dsn}, login => $params{login}, passwd => $params{passwd}, attrs => {}, sets => [], %params, ); # Implement SQL debugging if ( $params{debug_sql} ) { $self->{debug_sql} = 1; } # Create object accessor for DBMS handler $self->mk_accessors('dbh'); # Add initialization SQL queries $self->_add_sets( @{$sets} ); $attrs->{PrintError} = 0; $self->_add_attrs( %{$attrs} ); # Connect to DBMS $self->_connect(); return $self; } ## end sub new #*********************************************************************** =item B - DBI connection handler accessor Returns: DBI object This method provides accessor to DBI object and for low level access to database specific methods. Example (access to specific method): my $quoted = $db->dbh->quote_identifier(undef, 'auth', 'services'); # $quoted contains "auth"."services" now =cut #----------------------------------------------------------------------- #*********************************************************************** =item B - prepare and execute SQL query Method C implements the following functionality: * check connection to DBMS and restore it * prepare chached SQL statement * execute statement with bind parameters Parameters: * SQL query with placeholders * bind parameters Return: * statement handler from DBI Example: $sth = $dbh->call("select * from users"); while (my $row = $sth->fetchrow_hashref()) { print $row->{username}; } =cut #----------------------------------------------------------------------- sub call { my ( $self, $sql, @params ) = @_; # Debug SQL if ( $self->{debug_sql} ) { $self->log( "debug", "SQL: $sql" ); } # First check connection and try to restore if necessary unless ( $self->_check_connection() ) { return $self->error("Database connection error!"); } # Prepare cached SQL query # FIXME my $sth = $self->dbh->prepare_cached($sql); my $sth = $self->dbh->prepare($sql); unless ($sth) { return $self->error("Can't prepare SQL query: $sql"); } # Execute SQL query $sth->execute(@params); return $sth; } ## end sub call #*********************************************************************** =item B - call and fetch result Paramters: SQL query, parameters Returns: arrayref of records as hashrefs Example: # SQL DDL script: # create table users ( # id serial, # login varchar(32), # passwd varchar(32) # ); # Now we fetch all data to perl structure my $table_data = $db->fetch_call("select * from users"); # Process this data foreach my $user (@{$table_data}) { print "User ID: " . $user->{id}; print "Login: " . $user->{login}; } =cut #----------------------------------------------------------------------- sub fetch_call { my ( $self, $sql, @params ) = @_; # Try to prepare and execute SQL statement if ( my $sth = $self->call( $sql, @params ) ) { # Fetch all data as arrayref of hashrefs return $sth->fetchall_arrayref( {} ); } else { return $self->error("Can't execute SQL: $sql"); } } #*********************************************************************** =item B - start transaction =cut sub begin { my ($self) = @_; return $self->dbh->begin_work(); } #*********************************************************************** =item B - commit transaction =cut sub commit { my ($self) = @_; return $self->dbh->commit(); } #*********************************************************************** =item B - rollback transaction =cut sub rollback { my ($self) = @_; return $self->dbh->rollback(); } #*********************************************************************** =item B - quote SQL string Example: # Encode $str to use in queries my $str = "some crazy' string; with (dangerous characters"; $str = $db->quote($str); =cut sub quote { my ( $self, $str ) = @_; return $self->dbh->quote($str); } #*********************************************************************** =back =head1 INTERNAL METHODS =over =item B<_add_sets()> - add initial SQL query Example: $obj->_add_sets("set search_path to myscheme"); $obj->_add_sets("set client_encoding to 'UTF-8'"); =cut #----------------------------------------------------------------------- sub _add_sets { my ( $self, @sets ) = @_; push( @{ $self->{sets} }, @sets ); return 1; } #*********************************************************************** =item B<_add_attrs()> - add DBI handler attributes $self->_add_attrs(AutoCommit => 1); =cut #----------------------------------------------------------------------- sub _add_attrs { my ( $self, %attrs ) = @_; %attrs = ( %{ $self->{attrs} }, %attrs ); return %attrs; } #*********************************************************************** =item B<_check_connection()> - ping and reconnect Internal method checking connection and implement reconnect =cut #----------------------------------------------------------------------- sub _check_connection { my ($self) = @_; if ( $self->dbh ) { if ( $self->dbh->ping() ) { return 1; } else { return $self->_connect(); } } } #*********************************************************************** =item B<_connect()> - connect to DBMS Internal method starting connection to DBMS =cut #----------------------------------------------------------------------- sub _connect { my ($self) = @_; # Try to connect to DBMS $self->dbh( DBI->connect_cached( $self->{dsn}, $self->{login}, $self->{passwd}, $self->{attrs} ) ); if ( $self->dbh ) { # All OK - drop error state $self->error(undef); # Call startup SQL queries foreach my $row ( @{ $self->{sets} } ) { unless ( $self->dbh->do($row) ) { return $self->error( $self->dbh->errstr || 'Set error in connect' ); } } } else { return $self->error( "Can't connect to DBMS: " . $DBI::errstr ); } } ## end sub _connect 1; __END__ =back =head1 EXAMPLES samples/testdb.pl =head1 SEE ALSO L, L =head1 TODO 1. Make module less PostgreSQL specific. =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS/EDR.pm0000444000076400007640000000676611276226752014457 0ustar mishamisha#=============================================================================== # # FILE: EDR.pm # # DESCRIPTION: Module for reading/writing Event Details Records # # NOTES: --- # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 28.08.2009 16:43:02 EEST #=============================================================================== =head1 NAME NetSDS::EDR - read/write Event Details Records =head1 SYNOPSIS use NetSDS::EDR; my $edr = NetSDS::EDR->new( filename => '/mnt/billing/call-stats.dat', ); ... $edr->write( { callerid => '80441234567', clip => '89001234567', start_time => '2006-12-55 12:21:46', end_time => '2008-12-55 12:33:22' } ); =head1 DESCRIPTION C module implements API for writing EDR (Event Details Record) files form applications. EDR itself is set of structured data describing details of some event. Exact structure depends on event type and so hasn't fixed structure. In NetSDS EDR data is written to plain text files as JSON structures one row per record. =cut package NetSDS::EDR; use 5.8.0; use strict; use warnings; use JSON; use NetSDS::Util::DateTime; use base 'NetSDS::Class::Abstract'; use version; our $VERSION = '1.301'; #=============================================================================== # =head1 CLASS API =over =item B - class constructor Parameters: * filename - EDR file name Example: my $edr = NetSDS::EDR->new( filename => '/mnt/stat/ivr.dat', ); =cut #----------------------------------------------------------------------- sub new { my ( $class, %params ) = @_; my $self = $class->SUPER::new(%params); # Create JSON encoder for EDR data processing $self->{encoder} = JSON->new(); # Initialize file to write if ( $params{filename} ) { $self->{edr_file} = $params{filename}; } else { return $class->error("Absent mandatory parameter 'filename'"); } return $self; } #*********************************************************************** =item B - write EDR to file This methods converts records to JSON and write to file. Each record writing to one separate string. Example: $edr->write({from => '380441234567', to => '5552222', status => 'busy'}); =cut #----------------------------------------------------------------------- sub write { my ( $self, @records ) = @_; open EDRF, ">>$self->{edr_file}"; # Write records - one record per line foreach my $rec (@records) { my $edr_json = $self->{encoder}->encode($rec); print EDRF "$edr_json\n"; } close EDRF; } 1; __END__ =back =head1 EXAMPLES See C directory. =head1 TODO * Handle I/O errors when write EDR data. =head1 AUTHOR Michael Bochkaryov =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/lib/NetSDS.pm0000444000076400007640000000540511276226752014032 0ustar mishamisha#=============================================================================== # # MODULE: NetSDS # # DESCRIPTION: NetSDS framework # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # #=============================================================================== package NetSDS; use 5.8.0; use strict; use warnings; use version; our $VERSION = '1.301'; 1; =head1 NAME B - Service Delivery Suite by Net Style =head1 DESCRIPTION C is a flexible framework for rapid software development using the following technologies: =over =item B - default programming language =item B - default DBMS =item B - message queue manager =item B - HTTP server with FastCGI support =item B - SMS and WAP gateway =item B - VoIP / telephony applications =item B - MMSC and MMS VAS gateway =back =head1 COMPONENTS =over =item * L - abstract class for other NetSDS classes. =item * L - common application framework class. =item * L - FastCGI applicatrion framework =item * L - JSON-RPC server framework =item * L - configuration files management class. =item * L - syslog API. =item * L - DBI wrapper for DBMS integration. =item * L - SQL table data processing API. =item * L - writing event detail records (EDR). =back =head1 SEE ALSO =over =item L - Net Style Ltd. Company that develops NetSDS. =item L - NetSDS page at SourceForge =item L - Asterisk IP PBX =item L - Kannel WAP/SMS gateway =item L - Mbuni MMSC and MMS VAS gateway =item L - PostgreSQL object-relational DBMS =back =head1 AUTHORS Michael Bochkaryov =head1 THANKS Valentyn Solomko - for Wono project =head1 LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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 =cut NetSDS-1.301/samples/0000755000076400007640000000000011277046434013266 5ustar mishamishaNetSDS-1.301/samples/testdb.pl0000555000076400007640000000234511242537631015111 0ustar mishamisha#!/usr/bin/env perl use 5.8.0; use strict; use warnings; use NetSDS::DBI; use NetSDS::DBI::Table; use Data::Dumper; my $db = NetSDS::DBI->new( dsn => 'dbi:Pg:dbname=test_netsds;host=192.168.1.50;port=5432', login => 'netsds', passwd => '', ); #print Dumper($db); #print Dumper($db->dbh->selectrow_hashref("select md5('sdasd')")); #print $db->call("select md5(?)", 'zuka')->fetchrow_hashref->{md5}; #print Dumper($db->call('select * from auth.groups where $1 @> array[id]', [2,6])->fetchall_hashref("id")); my $tbl = NetSDS::DBI::Table->new( dsn => 'dbi:Pg:dbname=test_netsds;host=192.168.1.50;port=5432', login => 'netsds', passwd => '', table => 'auth.users', ); #print $tbl->insert_row( # login => 'vasya', # password => 'zzz', #); #my @uids = $tbl->insert( # { login => 'masha', password => 'zzz', }, # { login => 'lena', password => 'zzz', active => 'false' }, #); # #print "Inserted: " . join (', ', @uids) . "\n"; $tbl->update( filter => ["login = 'misha'"], set => { active => 'false', } ); $tbl->update_row(2, active => 'true'); my @res = $tbl->fetch( fields => [ 'login', 'id', 'active as act' ], #filter => [ 'active = true', 'expire > now()' ], order => ['login'], ); warn Dumper( \@res ); 1; NetSDS-1.301/samples/test_codings.pl0000555000076400007640000000064111174633377016316 0ustar mishamisha#!/usr/bin/env perl use warnings; use strict; use URI::Escape; use NetSDS::Util::Text qw(text_encode text_decode text_recode); use NetSDS::Util::Misc qw(str2uri); my $var = "жопа жопа жопа проверка связи 3-й раз блин не то бегает, что нескол"; $var = text_encode($var); $var = text_decode($var, "UTF16-BE"); print length($var) . uri_escape($var,"\0-\xff"); NetSDS-1.301/samples/app_jsrpc.fcgi0000555000076400007640000000034211240232522016062 0ustar mishamisha#!/usr/bin/env perl use lib '/home/misha/git/NetSDS/perl-NetSDS/NetSDS/lib'; MyApp->run; 1; package MyApp; use base 'NetSDS::App::JSRPC'; sub sum { my ($this, $params) = @_; return $$params[0] + $$params[1]; } 1; NetSDS-1.301/samples/test_edr.pl0000555000076400007640000000071311247213134015424 0ustar mishamisha#!/usr/bin/env perl use warnings; use strict; use lib '../lib'; use NetSDS::EDR; use Data::Dumper; my $edr = NetSDS::EDR->new(filename=>'/tmp/edrfile'); #print NetSDS::EDR->errstr; print Dumper($edr); $edr->write( { msgid => '123123@system.name', src_addr => '1234@mts', dst_addr => '380501234567@mts', tm => time, }, { msgid => '123123@system.name', src_addr => '1234@kyivstar', dst_addr => '380672222222@ks', tm => time, }, ); 1; NetSDS-1.301/samples/app_feature.pl0000555000076400007640000000047711174633377016133 0ustar mishamisha#!/usr/bin/env perl MyApp->run( daemon => 0, conf_file => './app_feature.conf', auto_features => 1, ); 1; package MyApp; use 5.8.0; use warnings; use strict; use Data::Dumper; use base 'NetSDS::App'; sub process { my ($this) = @_; print Dumper($this); $this->dbh->log("info", "feature logging"); } 1; NetSDS-1.301/samples/app_simple.pl0000555000076400007640000000245711257406551015763 0ustar mishamisha#!/usr/bin/env perl =head1 SYNOPSIS Options: --help - this message --version - show application version --verbose - increase verbosity level --daemon - run as daemon C is an example for NetSDS application developers. =cut use version; our $VERSION = "1.001"; MyApp->run( infinite => 1, # infinite loop daemon => 0, # not a daemon has_conf => 0, # no configuration verbose => 1, # verbose mode on use_pidfile => 1, edr_file => './test.edr', ); 1; package MyApp; use 5.8.0; use warnings; use strict; use lib '../lib'; # Inherits NetSDS::App features use base 'NetSDS::App'; sub start { my ($this) = @_; print "Application started: name=" . $this->name . "\n"; if ( $this->debug ) { print "We are under debug!\n"; } use Data::Structure::Util; my $zuka = Data::Structure::Util::signature($this); print "Z: $zuka\n"; } sub process { my ($this) = @_; for ( my $i = 1 ; $i <= 3 ; $i++ ) { # Do something and add messages to syslog print "PID=" . $this->pid . "; iteration: $i\n"; $this->log( "info", "My PID: " . $this->pid . "; iteration: $i" ); $this->edr( { pid => $this->pid, iteration => $i } ); sleep 1; } } sub stop { my ($this) = @_; print "Finishing application at last. Bye! :-)\n"; } 1; NetSDS-1.301/samples/serialize.pl0000555000076400007640000000061711174633377015623 0ustar mishamisha#!/usr/bin/env perl use 5.8.0; use strict; use warnings; use Data::Dumper; use NetSDS::Class::Abstract; my $obj = NetSDS::Class::Abstract->new( zuka => '123', buka => 'sdfsdf', ); print Dumper($obj); print "Serializing... "; my $ser = $obj->serialize(); my $new = NetSDS::Class::Abstract->deserialize($ser); print "done\n"; print Dumper($new); #$obj->nstore("/tmp/_tmp_obj.stor" ); 1; NetSDS-1.301/samples/app_feature.conf0000444000076400007640000000023311221676177016426 0ustar mishamishaapp_name = app_feature # DBMS plugin configuration class NetSDS::Feature dsn dbi:Pg:dbname=netsds user netsds passwd secret NetSDS-1.301/samples/daemon.pl0000555000076400007640000000110511174633377015070 0ustar mishamisha#!/usr/bin/env perl use Data::Dumper; MyApp->run( daemon => 0 ); print Dumper($c); 1; package MyApp; use Data::Dumper; use base 'NetSDS::App'; sub start { my ($this) = @_; $this->use_features('NetSDS::Kannel' => 'kannel'); print Dumper($this); } sub process { my $this = shift; for (my $i=1; $i<10; $i++) { $this->log( "info", "My PID: " . $$a ."; iteration: $i" ); sleep 1; } #print Dumper($this); #$this->{resp}->{data} = Dumper($this); #$this->{resp}->{mime} = 'text/plain'; #$this->{resp}->{data} = "TEST: " . $this->cgi->param('test'); } 1; NetSDS-1.301/samples/test_fcgi.pl0000555000076400007640000000075011174633377015601 0ustar mishamisha#!/usr/bin/env perl use Data::Dumper; MyApp->run; print Dumper($c); 1; package MyApp; use Data::Dumper; use base 'NetSDS::App::FCGI'; sub process { my ($this) = @_; #$this->redirect("/here"); $this->set_cookie(name => "name1", value => '123123'); $this->set_cookie(name => "here", value => 'ggggg', expires => "+1h"); $this->mime('text/xml'); $this->charset('koi8-u'); $this->data('Here is some HTML ;-)'); print Dumper($this->get_cookie('val')); } 1; NetSDS-1.301/Changes0000444000076400007640000000430311276227403013107 0ustar mishamisha1.301 Tue Nov 10 11:13:39 EET 2009 - significantly improved POD documentation - reimplemented NetSDS::Session - implemented transactions support in DBI wrapper - some minor fixes 1.300 Mon Oct 26 19:41:54 EEST 2009 - changed copyright to Net Style Ltd. without license changes - improved POD documentation - added INTERVAL_MINUTE and LANG_DE constants - fixed facility support in Logger.pm - fixed error handling in NetSDS::DBI::_connect() - removed clone() support from NetSDS::Class::Abstract (move to separate module) - removed Class::Accessor inheritance due to Class::Accessor::Class do the same things - simplified abstract constructor (now we accept only hashes) - removed Storable based (de)serialization from abstract class - implemented own error handling instead of Class::ErrorHandler - updated testcases - fixed some small bugs 1.206 Tue Oct 13 16:49:19 EEST 2009 - POD documentation improved - added autoflushing in NetSDS::App::FCGI - implement can_method() in JSRPC.pm to use instead of can() - avoid log() call if can't execute one - added "sql_debug" feature to NetSDS::DBI - added fields list support to NetSDS::DBI::Table - new NetSDS::EDR module to manage EDR files - new NetSDS::Session module to manage sessions in MemcacheD 1.205 Fri Sep 18 19:09:48 EEST 2009 - added NetSDS::Translate wrapper to gettext - added NetSDS::Template wrapper to HTML::Template::Pro - fixed get_count() in NetSDS::DBI::Table - added default_filter parameter to NetSDS::DBI::Table - added fetch_call() method to NetSDS::DBI 1.204 Wed Sep 16 21:34:45 EEST 2009 - added NetSDS::App::SMTPD - renamed $this to $self everywhere - POD documentation improved 1.203 Sat Sep 12 20:49:47 EEST 2009 - implemented EDR support for billing statistics - switch off verbosity for daemons and FCGI 1.202 Wed Aug 26 20:22:56 EEST 2009 - fixed PID retrieving after daemonization - added logging if already running - removed config search in 'admin' directory - removed stupid check for 'to_finalize' to set it 1.201 Tue Aug 18 18:15:34 EEST 2009 - NetSDS::DBI::Table implemented 1.200 Thu Aug 13 17:13:56 EEST 2009 - added NetSDS::App::JSRPC framework - updated versions for all modules 1.103 Thu Aug 13 16:14:38 EEST 2009 - POD documentation improved NetSDS-1.301/MANIFEST0000444000076400007640000000130211277046426012746 0ustar mishamishaBuild.PL Changes lib/NetSDS.pm lib/NetSDS/App.pm lib/NetSDS/App/FCGI.pm lib/NetSDS/App/JSRPC.pm lib/NetSDS/App/SMTPD.pm lib/NetSDS/Class/Abstract.pm lib/NetSDS/Conf.pm lib/NetSDS/Const.pm lib/NetSDS/DBI.pm lib/NetSDS/DBI/Table.pm lib/NetSDS/EDR.pm lib/NetSDS/Feature.pm lib/NetSDS/Logger.pm lib/NetSDS/Session.pm lib/NetSDS/Template.pm lib/NetSDS/Translate.pm Makefile.PL MANIFEST This list of files META.yml README samples/app_feature.conf samples/app_feature.pl samples/app_jsrpc.fcgi samples/app_simple.pl samples/daemon.pl samples/serialize.pl samples/test_codings.pl samples/test_edr.pl samples/test_fcgi.pl samples/testdb.pl t/01_load.t t/02_pod.t t/03_pod_coverage.t t/06_methods_class_abstract.t NetSDS-1.301/META.yml0000444000076400007640000000410511277046434013071 0ustar mishamisha--- name: NetSDS version: 1.301 author: - 'Net.Style Development Team ' abstract: Core Perl5 modules for NetSDS VAS development framework license: gpl resources: license: http://opensource.org/licenses/gpl-license.php requires: CGI: 3.29 CGI::Cookie: 0 CGI::Fast: 0 Class::Accessor: 0 Class::Accessor::Class: 0 Config::General: 0 DBD::Pg: 0 DBI: 1.600 Data::Structure::Util: 0 FCGI: 0.67 Getopt::Long: 0 HTML::Template::Pro: 0.81 JSON: 2.0 JSON::XS: 2.0 Locale::gettext: 1.00 POSIX: 0 Proc::Daemon: 0.03 Proc::PID::File: 0 Storable: 2.15 Unix::Syslog: 1.0 perl: 5.008 version: 0.700 build_requires: Module::Build: 0 Test::More: 0 Test::Pod: 0 Test::Pod::Coverage: 0 provides: NetSDS: file: lib/NetSDS.pm version: 1.301 NetSDS::App: file: lib/NetSDS/App.pm version: 1.301 NetSDS::App::FCGI: file: lib/NetSDS/App/FCGI.pm version: 1.301 NetSDS::App::JSRPC: file: lib/NetSDS/App/JSRPC.pm version: 1.301 NetSDS::App::SMTPD: file: lib/NetSDS/App/SMTPD.pm NetSDS::App::SMTPD::Client: file: lib/NetSDS/App/SMTPD.pm NetSDS::App::SMTPD::Socket: file: lib/NetSDS/App/SMTPD.pm version: 1.301 NetSDS::Class::Abstract: file: lib/NetSDS/Class/Abstract.pm version: 1.301 NetSDS::Conf: file: lib/NetSDS/Conf.pm version: 1.301 NetSDS::Const: file: lib/NetSDS/Const.pm version: 1.301 NetSDS::DBI: file: lib/NetSDS/DBI.pm version: 1.301 NetSDS::DBI::Table: file: lib/NetSDS/DBI/Table.pm version: 1.301 NetSDS::EDR: file: lib/NetSDS/EDR.pm version: 1.301 NetSDS::Feature: file: lib/NetSDS/Feature.pm version: 1.301 NetSDS::Logger: file: lib/NetSDS/Logger.pm version: 1.301 NetSDS::Session: file: lib/NetSDS/Session.pm version: 1.301 NetSDS::Template: file: lib/NetSDS/Template.pm version: 1.301 NetSDS::Translate: file: lib/NetSDS/Translate.pm version: 1.301 generated_by: Module::Build version 0.3 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 NetSDS-1.301/t/0000755000076400007640000000000011277046434012065 5ustar mishamishaNetSDS-1.301/t/01_load.t0000444000076400007640000000204211257152416013461 0ustar mishamisha#!/usr/bin/env perl #=============================================================================== # # FILE: 01_load.t # # DESCRIPTION: Check if all modules are loading without errors # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # VERSION: 1.0 # CREATED: 13.07.2008 23:48:53 EEST # REVISION: $Id: 01_load.t 49 2008-07-30 08:31:41Z misha $ #=============================================================================== use strict; use warnings; use Test::More tests => 16; # last test to print BEGIN { use_ok('NetSDS'); use_ok('NetSDS::Class::Abstract'); use_ok('NetSDS::Conf'); use_ok('NetSDS::Const'); use_ok('NetSDS::DBI'); use_ok('NetSDS::DBI::Table'); use_ok('NetSDS::EDR'); use_ok('NetSDS::Feature'); use_ok('NetSDS::Logger'); use_ok('NetSDS::Session'); use_ok('NetSDS::Template'); use_ok('NetSDS::Translate'); use_ok('NetSDS::App'); use_ok('NetSDS::App::FCGI'); use_ok('NetSDS::App::JSRPC'); use_ok('NetSDS::App::SMTPD'); } NetSDS-1.301/t/06_methods_class_abstract.t0000444000076400007640000000225111271103315017252 0ustar mishamisha#!/usr/bin/env perl #=============================================================================== # # FILE: 06_methods_class_abstract.t # # DESCRIPTION: Test methods availability # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # CREATED: 25.09.2009 17:35:42 EEST #=============================================================================== use strict; use warnings; use Test::More tests => 13; # last test to print use NetSDS::Class::Abstract; can_ok( 'NetSDS::Class::Abstract', 'new' ); can_ok( 'NetSDS::Class::Abstract', 'mk_accessors' ); can_ok( 'NetSDS::Class::Abstract', 'mk_ro_accessors' ); can_ok( 'NetSDS::Class::Abstract', 'mk_wo_accessors' ); can_ok( 'NetSDS::Class::Abstract', 'mk_package_accessors' ); can_ok( 'NetSDS::Class::Abstract', 'mk_class_accessors' ); can_ok( 'NetSDS::Class::Abstract', 'use_modules' ); can_ok( 'NetSDS::Class::Abstract', 'unbless' ); can_ok( 'NetSDS::Class::Abstract', 'log' ); can_ok( 'NetSDS::Class::Abstract', 'logger' ); can_ok( 'NetSDS::Class::Abstract', 'error' ); can_ok( 'NetSDS::Class::Abstract', 'errstr' ); can_ok( 'NetSDS::Class::Abstract', 'errcode' ); 1; NetSDS-1.301/t/02_pod.t0000444000076400007640000000130311174633377013334 0ustar mishamisha#!/usr/bin/env perl #=============================================================================== # # FILE: 02_pod.t # # DESCRIPTION: # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # VERSION: 1.0 # CREATED: 13.07.2008 23:51:01 EEST # REVISION: $Id: 02_pod.t 8 2008-07-13 21:11:35Z misha $ #=============================================================================== use strict; use warnings; use Test::More; # last test to print # We need at least 1.14 version to check POD data eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); NetSDS-1.301/t/03_pod_coverage.t0000444000076400007640000000125211174633377015213 0ustar mishamisha#!/usr/bin/env perl #=============================================================================== # # FILE: 03_pod_coverage.t # # DESCRIPTION: Check POD coverage # # AUTHOR: Michael Bochkaryov (Rattler), # COMPANY: Net.Style # VERSION: 1.0 # CREATED: 13.07.2008 23:54:48 EEST # REVISION: $Id: 03_pod_coverage.t 8 2008-07-13 21:11:35Z misha $ #=============================================================================== use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok(); NetSDS-1.301/Build.PL0000444000076400007640000000325411276226634013121 0ustar mishamisha#!/usr/bin/env perl =head1 NAME Build.PL - Build script generator for NetSDS core libraries =head1 SYNOPSIS perl Build.PL ./Build ./Build test ./Build install =cut use strict; use warnings 'all'; use Module::Build; my $build = Module::Build->new( module_name => 'NetSDS', dist_name => 'NetSDS', dist_abstract => 'Core Perl5 modules for NetSDS VAS development framework', create_makefile_pl => 'traditional', dist_author => 'Net.Style Development Team ', create_readme => 1, license => 'gpl', build_requires => { 'Test::More' => '0', 'Test::Pod' => '0', 'Test::Pod::Coverage' => '0', 'Module::Build' => '0', }, requires => { 'perl' => '5.008', 'version' => '0.700', 'CGI' => '3.29', 'CGI::Cookie' => '0', 'CGI::Fast' => '0', 'DBI' => '1.600', 'DBD::Pg' => '0', 'FCGI' => '0.67', 'JSON' => '2.0', 'JSON::XS' => '2.0', 'Class::Accessor' => '0', 'Class::Accessor::Class' => '0', 'Config::General' => '0', 'Data::Structure::Util' => '0', 'Getopt::Long' => '0', 'HTML::Template::Pro' => '0.81', 'Locale::gettext' => '1.00', 'POSIX' => '0', 'Proc::Daemon' => '0.03', 'Proc::PID::File' => '0', 'Storable' => '2.15', 'Unix::Syslog' => '1.0', }, recommends => {}, script_files => {}, ); $build->create_build_script; __END__ =head1 AUTHOR Michael Bochkaryov =cut NetSDS-1.301/Makefile.PL0000444000076400007640000000312711277046433013574 0ustar mishamisha# Note: this file was auto-generated by Module::Build::Compat version 0.30 require 5.008; use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'NetSDS', 'VERSION_FROM' => 'lib/NetSDS.pm', 'PREREQ_PM' => { 'CGI' => '3.29', 'CGI::Cookie' => '0', 'CGI::Fast' => '0', 'Class::Accessor' => '0', 'Class::Accessor::Class' => '0', 'Config::General' => '0', 'DBD::Pg' => '0', 'DBI' => '1.600', 'Data::Structure::Util' => '0', 'FCGI' => '0.67', 'Getopt::Long' => '0', 'HTML::Template::Pro' => '0.81', 'JSON' => '2.0', 'JSON::XS' => '2.0', 'Locale::gettext' => '1.00', 'Module::Build' => '0', 'POSIX' => '0', 'Proc::Daemon' => '0.03', 'Proc::PID::File' => '0', 'Storable' => '2.15', 'Test::More' => '0', 'Test::Pod' => '0', 'Test::Pod::Coverage' => '0', 'Unix::Syslog' => '1.0', 'version' => '0.700' }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; NetSDS-1.301/README0000444000076400007640000000430011277046433012474 0ustar mishamishaNAME NetSDS - Service Delivery Suite by Net Style DESCRIPTION "NetSDS" is a flexible framework for rapid software development using the following technologies: Perl5 - default programming language PostgreSQL - default DBMS MemcacheQ - message queue manager Apache - HTTP server with FastCGI support Kannel - SMS and WAP gateway Asterisk - VoIP / telephony applications Mbuni - MMSC and MMS VAS gateway COMPONENTS * NetSDS::Class::Abstract - abstract class for other NetSDS classes. * NetSDS::App - common application framework class. * NetSDS::App::FCGI - FastCGI applicatrion framework * NetSDS::App::JSRPC - JSON-RPC server framework * NetSDS::Conf - configuration files management class. * NetSDS::Logger - syslog API. * NetSDS::DBI - DBI wrapper for DBMS integration. * NetSDS::DBI::Table - SQL table data processing API. * NetSDS::EDR - writing event detail records (EDR). SEE ALSO - Net Style Ltd. Company that develops NetSDS. - NetSDS page at SourceForge - Asterisk IP PBX - Kannel WAP/SMS gateway - Mbuni MMSC and MMS VAS gateway - PostgreSQL object-relational DBMS AUTHORS Michael Bochkaryov THANKS Valentyn Solomko - for Wono project LICENSE Copyright (C) 2008-2009 Net Style Ltd. 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