分类目录归档:Perl

net::smtp with net::socks

use Net::SMTP;
use Net::SOCKS;
my $socks = new Net::SOCKS(socks_addr=>$shost,socks_port=>$sport, protocol_version=>5) or die $!; 
my $socksfd = $socks->connect(peer_addr=>$smtp_server,peer_port=>25);
if(!$socksfd){
    die "Connection to SOCKS failed";
}
my $smtp = Net::SMTP->new_from_fd($socksfd->fileno, 'r+' ) or die $!;

#HACK: there is "220 host.domain.net" line we must read otherwise Net::SMTP would not work!
$smtp->getline();

$smtp->hello("localhost") or die $smtp->message();
#from here Net::SMTP business as usual...

 

a perl mail proxy 2

#!/usr/bin/perl -w
# 
# Olivier Poitrey <rs@rhapsodyk.net>
# 8th november 2002
# 
# smtp-gateway.pl: A simple SMTP gateway example.

require 5.006;
use strict;
use POSIX qw(setsid);
use Getopt::Std;
use IO::Socket;
use IO::Select;
use Net::Server::Mail::ESMTP;
use Net::SMTP;


my %opts = (p => 25, h => 'localhost', r => '', d => 0);
getopts('dp:h:r:', \%opts);

my $remote = $opts{r};
unless($remote)
{
    print STDERR "Needs a remote server (-r option)\n";
    exit 1;
}

unless($opts{d})
{
    # become a daemon
    fork and exit;
    setsid;
}

# start to listen
my $server = IO::Socket::INET->new(
    Listen      => 1,
    LocalPort   => $opts{p},
    LocalHost   => $opts{h},
) or die "can't listen $opts{h}:$opts{p}";
my $select = IO::Select->new($server);

my(@ready, $fh, %session_pool);
while(@ready = $select->can_read)
{
    foreach $fh (@ready)
    {
        if($fh == $server)
        {
            my $new = $server->accept();
            $new->blocking(0);
            my $smtpout = Net::SMTP->new( $remote, Debug => $opts{d} ) or do
            {
                $new->print("Service unavailable\n");
                $new->close();
            };
            my $smtpin = Net::Server::Mail::ESMTP->new( socket => $new )
              or die "can't start server on port $opts{p}";
            $smtpin->register('Net::Server::Mail::ESMTP::PIPELINING');
            $smtpin->register('Net::Server::Mail::ESMTP::8BITMIME');
            $smtpin->set_callback(HELO => \&gate_helo, $smtpout);
            $smtpin->set_callback(MAIL => \&gate_mail, $smtpout);
            $smtpin->set_callback(RCPT => \&gate_rcpt, $smtpout);
            $smtpin->set_callback('DATA-INIT' => \&gate_datainit, $smtpout);
            $smtpin->set_callback('DATA-PART' => \&gate_datapart, $smtpout);
            $smtpin->set_callback(DATA => \&gate_dataend, $smtpout);
            $smtpin->set_callback(QUIT => \&gate_quit, $smtpout);
            $smtpin->banner();
            $session_pool{$new} = $smtpin;
            $select->add($new);
        }
        else
        {
            my $operation = join '', <$fh>;
            my $rv = $session_pool{$fh}->process_once($operation);
            if(defined $rv)
            {
                $select->remove($fh);
                delete $session_pool{$fh};
                $fh->close();
            }
        }
    }
}

sub gate_helo
{
    # Net::SMTP send HELO by himself
    return;
}

sub gate_mail
{
    my($session, $address) = @_;
    my $smtpout = $session->get_context();
    return $smtpout->mail($address);
}

sub gate_rcpt
{
    my($session, $address) = @_;
    my $smtpout = $session->get_context();
    return $smtpout->to($address);
}

sub gate_datainit
{
    my($session) = @_;
    my $smtpout = $session->get_context();
    return $smtpout->data();
}

sub gate_datapart
{
    my($session, $dataref) = @_;
    my $smtpout = $session->get_context();
    return $smtpout->datasend($$dataref);
}

sub gate_dataend
{
    my($session, $dataref) = @_;
    my $smtpout = $session->get_context();
    return $smtpout->dataend();
}

sub gate_quit
{
    my($session) = @_;
    my $smtpout = $session->get_context();
    return $smtpout->quit();
}

 

a perl mail proxy

############################################################################
#
#	Simple Mail Proxy
#
############################################################################

use Carp;
use Net::SMTP;
use Net::SMTP::Server;
use Mail::Message;
use Sys::Hostname;

use strict;

my $debug = 0;


## SMTP server address and port ##
#
my $SMTP_Server_Address = 'smtp.server.address';
my $SMTP_Server_Port = 25;


### Mail proxy (this server) address and port ##
#
my $Proxy_Port = 25;


#===========================================================================
#	Mail client connection service
#===========================================================================

### Constants ###

my $SUCCEEDED = 0;

my %commands = (DATA => \&cmd_data,
		EXPN => \&cmd_dummy,
		HELO => \&cmd_helo,
		HELP => \&cmd_help,
		MAIL => \&cmd_mail,
		NOOP => \&cmd_noop,
		QUIT => \&cmd_quit,
		RCPT => \&cmd_rcpt,
		RSET => \&cmd_rset,
		VRFY => \&cmd_dummy);

### Variables ###

my $client_socket;
my $from;
my @to;
my $message;


sub client_put ($) {
    my ($message) = @_;
    print "Sent:     $message\n" if ($debug);
    print $client_socket $message, "\r\n";
}

sub cmd_data () {
    if (!defined($from)) {
	client_put("503 5.5.1 Sender address not yet specified");
	return 1;
    };
    if (!@to) {
	client_put("503 5.5.1 Recepient address not yet specified");
	return 1;
    };
    client_put("354 Start mail input; end with .");

    my $done = 0;
    while (<$client_socket>) {
	# print "Received: $_" if ($debug);
	if (/^\.\r\n$/) {
	    $done = 1;
	    last;
	};
	s/^\.\./\./;
	$message .= $_;
    };
    if (!$done) {
	client_put("451 5.6.0 Message input failed");
	return 1;
    };
    return 0;
}

sub cmd_helo () {
    client_put("250-Action completed, okay");
    client_put("250 ENHANCEDSTATUSCODES");
}

sub cmd_help () {
    my $out = "214-Commands\r\n";
    my $total = keys %commands;
    my $i = 0;
    foreach my $cmd (keys %commands) {
	$out .= "\r\n214";
	if ($i++ % 5 != 0) {
	    $out .= $total - $i < 5 ? " " : "-";
	} else {
	    $out .= " ";
	};
    };
    client_put($out);
}

sub cmd_noop () {
    client_put("252 Unknown status, but attempting delivery");
}

sub cmd_quit () {
    client_put("221 Service closing");
    $client_socket->close();
    return 0;
}

sub cmd_mail ($) {
    my ($arg)  = @_;
    $arg =~ /FROM:\s*(\S+)$/i;
    $from = $1;
    client_put("250 Mail sender okay");
}

sub cmd_rcpt ($) {
    my ($arg) = @_;
    $arg =~ /TO:\s*(\S+)$/i;
    my $to = $1;
    push(@to, $to);
    client_put("250 Mail recepient okay");
}

sub cmd_rset () {
    $from = undef;
    @to = ();
    client_put("250 Reset action okay");
}

sub cmd_dummy () {
}



#===========================================================================
#	SMTP server connection service
#===========================================================================

### relay ($from, @to, $msg) ###
#   forward a mail to specified SMTP server
#
sub relay ($\@$) {
    my ($from, $to, $msg) = @_;
    
    $from =~ /<.*@(.*)>/;
    my $domain = $1;
    print "Domain: $domain\n" if ($debug);
    my $client = new Net::SMTP($SMTP_Server_Address, Port => $SMTP_Server_Port,
			       Hello => $domain, Timeout => 30, Debug => $debug) ||
	croak "Unable to connect to mail server: $!\n";
    if ($client) {
	$client->mail($from);
	foreach my $recipient (@$to) {
	    $client->to($recipient);
	};
	$client->data($msg);
	$client->quit() || croak "Relay failed: $!\n";
    };
}


#===========================================================================
#	Main
#===========================================================================

my $server = new Net::SMTP::Server(hostname(), $Proxy_Port) ||
    croak "Unable to create a new mail proxy: $!\n";

while ($client_socket = $server->accept()) {

    $from = undef;
    @to = ();
    $message = undef;
    my $accepted;

    client_put("220 Service ready");

    while (<$client_socket>) {
	print "Received: $_" if ($debug);
	chomp;
	my ($cmd, $arg);
	/^\s*(\S+)(\s+(.*\S))?\s*$/;
	$cmd = $1;
	$arg = $3;
	$cmd =~ tr/a-z/A-Z/;
	if (!defined($commands{$cmd})) {
	    client_put("500 5.5.2 Syntax error, command unrecognized");
	    next;
	};

	&{$commands{$cmd}}($arg);

	if ($cmd eq 'DATA') {
	    my $msg = Mail::Message->read($message);
	    my $body = $msg->body;
	    if ($body =~ /viagra/i) {
		client_put("554 5.6.0 Invalid keyword included: viagra");
		$accepted = 0;
	    } else {
		client_put("250 2.0.0 Message accepted for delivery");
		$accepted = 1;
	    };
	};
    };

    $client_socket->close();

    if ($accepted) {
	relay($from, @to, $message);
    };
}

 

perldancer 启动脚本-基于ubic

之前在网上找了几个启动脚本,都怪自己文档没有细看啊。其实dancer文档已经写得很详细了
https://metacpan.org/pod/Dancer2::Manual::Deployment

use qw(Ubic::Service::Plack);

# if your application is not installed in @INC path:
sub start {
    my $self = shift;
    $ENV{PERL5LIB} = '/home/perl_project/www.yiyou.org/lib/';
    $self->SUPER::start(@_);
}

__PACKAGE__->new(
    server_args=>{workers=>2,host=>'127.0.0.1' },
    server => 'Starman',
    app => '/home/perl_project/www.yiyou.org/bin/app.psgi',
    port => 8081,
    user => 'www-data',
);

 

perl-介绍一个好用的xml转hash包

最近一个项目里用到要将xml字符串转为perl-hash,在cpanm 试了很多软件包,发现xml::fast 这个是c写的,速度比较快,而且比较直观

使用方法

use XML::Fast;
 
my $hash = xml2hash $xml;
my $hash2 = xml2hash $xml, attr => '.', text => '~';

 

yunpian云片网短信发送-perl示例

#!/usr/bin/perl
# Author fy@yiyou.org
# Date  2016-09-11
# 云片网短信-perl发送短信示例
# 使用时,务必将文件保存为utf8格式,否则发送的中文会出现乱码

use strict;
use Data::Dumper;
use HTTP::Tiny;
use JSON;
use utf8;

my $tel='13800138000'; #手机号码
my $msg='【验证码】内容'; #发送内容,需要审核通过

my $response = HTTP::Tiny->new->post_form('https://sms.yunpian.com/v2/sms/single_send.json',
                {apikey=>'_your_apikey_here_', #apikey
                mobile=>$tel,
                text=>$msg});
#print Dumper $response;exit;
my $json=decode_json ($response->{content});
print Dumper $json;

 

perl生成yyyy-mm-dd H::i::s日期总结

1、

use POSIX qw(strftime);
print strftime("%Y-%m-%d %H:%M:%S",localtime());

2、

use Time::localtime;
$tm=localtime;
my ($day,$month,$year)=($tm->mday,$tm->month,$tm->year);

3、

use Time::Piece;

my $date = localtime->strftime('%m/%d/%Y');
print $date;

4、

use DateTime qw();
DateTime->now->strftime('%m/%d/%Y')

5、

use strict;
use warnings;
use Date::Calc qw();
my ($y, $m, $d) = Date::Calc::Today();
my $ddmmyyyy = sprintf '%02d.%02d.%d', $d, $m, $y;
print $ddmmyyyy . "\n";

6、

# Capture date from shell
my $current_date = `date +"%m/%d/%Y"`;

# Remove newline character
$current_date = substr($current_date,0,-1);

print $current_date, "\n";

 

perl简单记录程序运行日志

use Log::Logger;
use POSIX qw(strftime);
sub my_logger{
    my $msg=shift;
    my $time_f=strftime("%Y-%m-%d %H:%M:%S",localtime(time));
    my $lh = new Log::Logger;
    $lh->open_append("/var/log/jrmmadm_comment_notify.log");
    $lh->log($time_f.' '.$msg);
    $lh->close;
}
#使用
my_logger('www.yiyou.org');

 

perl过滤文件中标记区的行

perl群有一个网友提问,如何跳过文本文件中特定标记中,整块的行,想想这个问题有点意思,所以睡前思考了一下,把方法写了出来

use strict;


my $del_flag=0;

while(<DATA>){
	chomp;
	if($_=~/^\*block$/){
		#print "found \n";
		if($del_flag==0){
			$del_flag=1;
			next;
		}
		if($del_flag==1){
			$del_flag=0;
			next
		}
		
	}
	next if $del_flag==1;
	print $_,"\n";
}

__DATA__
aaa
aa33
dfsf
sfsf
----
*block
aaa
sfsf
*block
****
sfsfsfs
sfsfsfssfsf
sfsfsfssfsfsf
111111
*block
aaa
sfsf
*block
2222222

 

perl四舍五入

perl 里没有四舍五入函数,不过有个模块

https://metacpan.org/pod/Math::Round::Var

使用比较简单

use Math::Round::Var;
my $rnd = Math::Round::Var->new(0.01);
# rounds to two decimal places:
my $num = 399886.758673;
$num = $rnd->round($num);
print "$num\n"; # 399886.76