while( defined( my $item = $queue->dequeue() ) ) {

  # выполняем какие-либо действия.

}

#!/usr/bin/perl

use strict;

 

use Tkx; # тулкит

 

use threads; # работа с потоками

use Thread::Queue; # реализует очередь

 

# создаем очереди

my $queue_tk   = Thread::Queue->new(); # получаем задания из Tk

my $queue_job  = Thread::Queue->new(); # отправляем работникам

my $queue_box  = Thread::Queue->new(); # результаты

 

# босс

sub thread_boss {

    my $self = threads->self();

    my $tid  = $self->tid();

    

    while( defined( my $item = $queue_tk->dequeue() ) ) {

        print STDERR "Boss($tid) has received the task from Tk: $item\n";

        

        # отправляем задание на обработку работнику

        $queue_job->enqueue( $item );

    }

    

    $queue_job->enqueue( undef );

}

 

# работник(и)

sub thread_worker {

    my $self = threads->self();

    my $tid  = $self->tid();

    

    while( defined( my $job = $queue_job->dequeue() ) ) {

        print STDERR "Worker($tid) has received task from Boss: $job\n";

        

        # выполняем какую-нибудь работу...

        print STDERR "Worker($tid) has finished the task\n";

        

        # скидываем все в одну коробку ;)

        $queue_box->enqueue( "processed: $job" );

    }

 

    $queue_box->enqueue( undef );    

}

    

# создаем потоки

my $boss   = threads->new( \&thread_boss );

my $worker = threads->new( \&thread_worker );

 

 

# Создаем UI

my $main_window = Tkx::widget->new( '.' );

my $frame = $main_window->new_ttk__frame( -padding => q/10 10 10 10/ );

$frame->g_grid();

 

my $label = $frame->new_ttk__label( -text => 'waiting' );

$label->g_grid( -row => 0, -column => 0, -columnspan => 2 );

 

# поле для ввода

my $entry_data = 'enter data here';

my $entry = $frame->new_ttk__entry( -textvariable => $entry_data );

 

my $button = $frame->new_ttk__button(

    -text => 'Send to Boss',

    -command => sub {

        $queue_tk->enqueue( $entry_data );

    },

);

 

$entry->g_grid( -row => 1, -column => 0 );

$button->g_grid( -row => 1, -column => 1 );

 

# обработчик события WM_DELETE_WINDOW

sub on_destroy {

    my $mw = shift;

 

    # отсылаем очереди undef, что завершит потоки

    $queue_tk->enqueue( undef );

    $queue_box->enqueue( 'finish' );

 

    # Destroy

    # или Tkx::destroy( '.' )

    $mw->g_destroy();

}

 

$main_window->g_wm_protocol( 'WM_DELETE_WINDOW', [\&on_destroy, $main_window] );

 

# обрабатываем результат

sub monitor {

    my $status_lbl = shift;

    my $result = $queue_box->dequeue_nb;    

 

    if( $result ne 'finish' ) {

        if( defined $result ) {

            $label->configure( -text => "job completed: ".scalar(localtime));

        }

            

        Tkx::after( 1000, [\&monitor, $label]);

    }

    

}

 

# запускаем мониторинг

Tkx::after( 100, [\&monitor, $label] );

 

# открепляем потоки

# иначе при завершении программы, у нас будут предупреждения

# Perl exited with active threads:

#        2 running and unjoined

#        0 finished and unjoined

#        0 running and detached

$boss->detach();

$worker->detach();

 

Tkx::MainLoop();

use DBI;

 

$sql_user=$ENV{SQL_USER};

$sql_password=$ENV{SQL_PASSWD};

$sql_base=$ENV{SQL_BASE};

$sql_host=$ENV{SQL_HOST};

 

if (! $sql_user) { $sql_user="USERNAME"; }

if (! $sql_password) { $sql_password="PASSWORD"; }

if (! $sql_base) { $sql_base="DATABASE_NAME"; }

if (! $sql_host) { $sql_host="HOST"; }

 

if ($debug) {

        print "User:$sql_user\nPassword:$sql_password\n";

}

 

 

sub connect {

        my($u,$p)=@_;

 

        $sql_user=$u if $u;

        $sql_password=$p if $p;

 

if ($debug) {

        print "User:$sql_user\nPassword:$sql_password\n";

}

 

        $dbh = DBI->connect("DBI:mysql:$sql_base;host=$sql_host", $sql_user, $sql_password);

        $dbh->{RaiseError} = 1;

}

 

sub disconnect {

        $dbh->disconnect;

}

 

1;

use DBI;

require 'mysql.pm';

$sth=$dbh->prepare("SELECT * FROM SomeTable WHERE SomeData = 'test'");

$sth->execute || die $DBD::errstr;

 

while(($a,$b)=$sth->fetchrow) {

    print $a;

  }

#!/usr/bin/perl -w

print "Content-type: text/html\n\n";

print "Some tezt";

#!/usr/bin/perl -w

use CGI::WebOut;

print "Некоторый текст";

#!/usr/bin/perl

 

use Net::Telnet

 

$conn = new Net::Telnet (Timeout => 10,');

$conn->open("some.host.org");

$conn->login($username);

$conn->password($passwd);

@somedata = $conn->cmd("do something");

print @somedata;

12.23.45.54 dlink

24.21.23.54 dlink_simple

#!/usr/bin/perl

 

##########################################

##

## ololo

## (C) Ilya Vasilyev, 2010

## nadz.goldman@gmail.com

##

##########################################

##########################################

 

 

 

use Net::Telnet;

use File::Copy;

 

 

 

$cmd;

$host;

$type;

$conn;

 

# айпи тфтп сервера

$tftp_ip = "12.2.2.3";

 

# логин+пароль свича

$username = "bak";

$passwd = "bak";

 

# директория тфтп-сервера, в которую кидаются/из которой берутся файлы, прилетевшие на тфтп

$tftp_path = "/tftp";

 

# рабочая директория скрипта

$main_path = "/home/bak/ololo";

 

# так у меня выглядит дата

$date = `/bin/date "+%Y-%m-%d"`;

 

# это для винды

#$date = `date /T`;

 

# так выглядит имя файла конфигурации, прилетевшего со свича

$filename = $host."-".$date;

 

####################################################################################

 

# вызов подпрограммы для распарсивания файла с хостами

parse();

 

# выполнение бэкапа

execute();

 

# перенос в директорию бэкапа

mov_bak();

 

 

# подпрограмма переноса

sub mov_bak()

{

# обрезаем фигню всякую

chomp( $date );

 

# создаем директорию на текущую дату для бэкапа

system( "mkdir -p ".$main_path."/bak/".$date );

# двигаем туда прилетевшие к нам конфиги

system( "mv ".$tftp_path."/*_".$date." ".$main_path."/bak/".$date );

# скидываем в файл список пустых файлов - это те свичи, до которых мы либо не достучались, либо с них ничего не прилетело

system( "find ".$main_path."/bak/ -empty -exec ls {} \; > ".$main_path."/NOT_BACKUP.txt " );

}

 

sub put_conf()

{

# на будущее =))

# here I put new conf to switch

}

 

 

# подпрограмма соединения со свичом по телнету

sub connect_()

{

my $temp;

$temp = length( $host );

# если вдруг переменная $host оказалась пуста, значит какой-то ахтунг произошел и скрипт умирает

if( $temp == 0 ){ die "No ip address ( func::connect_ ) !\n Exiting...\n"; }

 

# опции соединения

$conn = new Net::Telnet( Timeout => 5 , Errmode => 'return' , Dump_Log => 'DUMP.LOG' );

$conn->open( Host=>$host );

 

# допиливаю вывод ошибок

$msg = $conn -> errmsg;

$prev = $conn -> errmsg( @msgs );

foreach $prev( @msgs ){ print "$prev\n"; }

 

# создание дампов

$dump = $conn -> dump_log;

$dump = $conn -> dump_log( $dump );

$dump = $conn -> dump_log( $main_path.'/dump/DUMP.LOG' );

 

# ожидаем строки UserName/PassWord и дождавшись, скидываем туда логин и пароль

# Можно и вот так: $conn -> waitfor( '/username[: ]*$/i' ); , но эт потом...

# Просто потому что некоторые свичи пишут login или сразу password

$conn -> waitfor( '/ame[: ]*$/' );

$conn -> print( $username );

$conn -> waitfor( '/ord[: ]*$/' );

$conn -> print( $passwd );

}

 

# дисконнектимся

sub disconnect()

{

$conn -> print( "logout" );

$conn -> close;

undef( $conn );

copy( $main_path.'/dumps/DUMP.LOG', $main_path.'/dumps/DUMP.LOG-'.$host );

}

 

 

# собственно здесь мы и забираем конфиг

sub get_conf()

{

my $temp;

$temp = length( $host );

# если вдруг переменная $host оказалась пуста, значит какой-то ахтунг произошел и скрипт умирает

if( $temp == 0 ){ die "No ip address ( func::get_conf ) !\n Exiting...\n"; }

 

# создаем файлик в директории тфтп сервера

tftp_create();

# говорим свичу команду на отправку конфига

$conn -> print( $cmd );

# ждем - иногда свичи тупят, если сразу отвалится, то глупости будут

sleep( 15 );

}

 

# подпрограмма создания файла в каталоге тфтп

sub tftp_create

{

my $temp;

$temp = length( $host );

# если вдруг переменная $host оказалась пуста, значит какой-то ахтунг произошел и скрипт умирает

if( $temp == 0 ){ die "No ip address ( func::tftp_create ) !\n Exiting...\n"; }

# создаем файл

system( "touch $tftp_path"."/"."$filename" );

# устанавливаем права

system( "chmod 0666 $tftp_path"."/"."$filename" );

# ждем...

sleep( 2 );

}

 

# подпрограмма выполнения

sub execute

{

my $i;

 

# ищем файлик со свичами цисок

if( -f $main_path."/cisco.txt" )

{

open( cs , "< ".$main_path."/cisco.txt" ) or print "While executing, can not open cisco.txt";

while( defined( $i = ))

{

print( "Yeeehaaa!!! It is CISCO!! =)) \n\n" );

}

close( cs );

}

# ищем файлик с длинками

if( -f $main_path."/dlink.txt" )

{

open( dl , "< ".$main_path."/dlink.txt" ) or print "While executing, can not open dlink.txt";

while( defined( $i =

 

))

{

chomp( $i );

$host = $i;

$filename = $host."_".$date;

# ВОТ эта команда будет сказана свичю после соедиенения и атворизации

$cmd = "upload cfg_toTFTP $tftp_ip $filename";

# для дебага =)

#print( "Host: $host\nfile: $filename cmd: $cmd" );

# соеденились

connect_();

# забрали

get_conf();

# ушли

disconnect();

}

close( dl );

}

# А! Вот эта штука... Потому что длинки разные, то и набор команд у них разный.

# сейчас как раз пилю что бы этой ереси с кучей файлов не было

if( -f $main_path."/dlink_simple.txt" )

{

open( dl_simple , "< ".$main_path."/dlink_simple.txt" ) or print "While executing, can not open dlink_simple.txt";

# upload configuration

while( defined( $i = ))

{

chomp( $i );

$host = $i;

$filename = $host."_".$date;

$cmd = "upload configuration $tftp_ip $filename";

#print( "Host: $host\nfile: $filename cmd: $cmd" );

connect_();

get_conf();

disconnect();

}

close( dl_simple );

}

return();

}

 

# подпрограмма парсинга

sub parse

{

my $i;

 

open( cs , "+> ".$main_path."/cisco.txt" ) or print( "Can not open cisco.txt\n" );

open( dl , "+> ".$main_path."/dlink.txt" ) or print( "Can not open dlink.txt\n" );

open( dl_simple , "+> ".$main_path."/dlink_simple.txt" ) or print( "Can not open dlink_simple.txt\n" );

open( err_txt , "+> ".$main_path."/error.txt" ) or print( "Can not open error.txt\n" );

 

open( fh , "< ".$main_path."/hosts.txt" ) or die "Can not open hosts.txt!\n";

flock( fh , 2 ) or die "Can not flock hosts.txt!\n";

while( defined( $i = ))

{

( $host, $type ) = split( / /, $i );

if( $type =~ /cisco/i )

{

#print "host = $host ... type = $type";

print cs "$host\n";

 

}

elsif( $type =~ /^dlink$/i )

{

#print "host = $host ... type = $type";

print dl "$host\n";

}

elsif( $type =~ /^dlink_simple$/i )

{

print dl_simple "$host\n";

}

else

{

print err_txt "$host $type\n";

}

}

close( fh );

close( cs );

close( dl );

close( err_txt );

close( dl_simple );

return();

}

sub mySomeSub {

# Здесь тело подпрограммы

}

sub mySumm {

    my ( $someVar1 , $someVar2 ) = @_;

    return ( $someVar1 + $someVar2 );

}

$f = scalar( @_ );

$myVar = mySumm( 10, 50 );

use Socket;

 

socket(TO_SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));

 

$internet_addr = inet_aton( $remote_host )

    or die "Не могу сделать резолв хоста $remote_host в ip: $!\n";

$paddr = sockaddr_in( $remote_port , $internet_addr );

 

 

connect(TO_SERVER, $paddr)

    or die "Не могу соеденится с $remote_host:$remote_port : $!\n";

 

# Организуем работу с сервером.

print TO_SERVER "HALO, SERVER!\n";

 

close(TO_SERVER);

use Socket;

 

socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));

 

setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);

 

$my_addr = sockaddr_in($server_port, INADDR_ANY);

bind(SERVER, $my_addr)

    or die "Не могу использовать порт $server_port : $!\n";

 

listen(SERVER, SOMAXCONN)

    or die "Не могу слушать порт: $server_port : $!\n";

 

while (accept(CLIENT, SERVER)) {

 print "Halo, my dear client!\n";

}

 

close(SERVER);

#!/usr/bin/env perl6

 

# see:

# * http://transfixedbutnotdead.com/2010/01/13/anyone_for_metaprogramming/

# * http://transfixedbutnotdead.com/2010/01/14/anyone-for-perl-6-metaprogramming/

# * http://fingernailsinoatmeal.com/post/292301859/metaprogramming-ruby-vs-javascript

 

# below runs on Rakudo (31-Oct-2009).

 

use v6;

 

class Ninja {

    has Str $.name is rw;

}

 

my Ninja $drew .= new( name => 'Drew' );

my Ninja $adam .= new( name => 'Adam' );

 

 

###########################################################

# Reopen Ninja class ("is also" does the biz)

# and add 'battle_cry' method

 

# augment class Ninja {}

class Ninja is also {

    method battle_cry {

        say $.name ~ ' says zing!!!';

    }

}

 

$drew.battle_cry; # => Drew says zing!!!

$adam.battle_cry; # => Adam says zing!!!

 

 

###########################################################

# add 'throw_star' method to $drew object by creating

# and applying ("does") role to it (Singleton method)

 

role ThrowStar {

    method throw_star { say "throwing star" }

}

 

$drew does ThrowStar;

$drew.throw_star; # => throwing a star

 

 

###########################################################

# call method dynamically

 

$drew.'battle_cry'; # => Drew says zing!!!

 

 

###########################################################

# add "colour" method closing over $colour_name (ie. closure):

 

my $colour_name = 'black';

 

class Ninja is also {

    method colour { say "{$.name}'s colour is $colour_name" }

}

 

$drew.colour; # => Drew's colour is black

$adam.colour; # => Adam's colour is black

 

 

###########################################################

 

# "defining a method dynamically on an instance that closes

# over local scope and accesses the instance’s state"

#

# Opps - Class method slipped in while working it out.

# $drew.^add_method() does a singleton method.. nice!

 

my $sword_symbol = '********';

 

$drew.^add_method( 'swing', method ( Str $sound_effect ) {

    say "$.name: $sword_symbol $sound_effect";

} );

 

$drew.swing( 'slash!!' );