в общем типо скриптик писался для хранения базы шеллов и проверки их на валид и пиар дописал потоки, сортировку по пиару + переработал очистку - конфиг внутри скрипта reset - обновляет контект Sort by PR - сортировка по пиару check & PR all -- проверяет все линки на шеллы и ставит пиар по сайту save - сохраняет список в файл clean body - очищает окно проги но не файл clean - очищает от мусора линки на шеллы export - экспорт списка для продажи + там еще возможность дампа в файл - по дефолту на рабочий стол в винде add to base добавление того что у вас в окне к файлу и обновление всего файла с дополнением сопстна все извра скриптик с извра кодом =) Code: #!/usr/bin/perl ################## shell<->commander V2 ################# # coded by genom-- # специально для antichat.ru - ачат мы любим тебя - держись. # NO SPLoA, NO WORLD !!!!! # Спасибо друзьям,одептам и моей маме. ################## волт 13. 2007 г.################# use Tk; use Tk::ROText; use Tk::Frame; use Tk::LabFrame; use Tk::BrowseEntry; use Tk::DialogBox; use LWP::UserAgent; use threads; use threads::shared; my $a:shared; open as,'<shell.txt' or open as,'>shell.txt';close as; my $ua = LWP::UserAgent->new; $ua->timeout(5); $ua->agent('Opera/9.00 (Windows NT 5.1; U; en)'); $ua->requests_redirectable(0); $col='#330000'; # цвет фона -- вынес в переменную чтобы могли поменять если комуто не понравится $tes='red'; # цвет шрифта в лейблах =) $bgform='#cccc99'; # цвет фона на текстовых полях $focofo='#006600'; # цвет шрифта в формах $butcol='#66cc33'; # цвет кнопок $ff='{Tahoma} 7 bold'; # шрифт $name='shell.txt'; # имя файла с бд. $dum='C:\Documents and Settings\All Users\Рабочий стол\dump.txt'; # путь для дампа $thr=3; # количество потоков $typak=new MainWindow(title=>"[shell<-->commander] v2 - Private edition - only for my friends",-bg=>$col); $typak->geometry('1015x500+0+190'); $typak->resizable(0,0); $knp=$typak->LabFrame(-label=>'Commands',-bg=>$col,-foreground=>$tes)->pack(); $zone=$typak->Frame(-bg=>$col,-foreground=>$tes)->pack(); $knp->Button(-text=>'RESET',-width=>'6',-font=>$ff,-command=>\&reset,-background=>$butcol)->pack(-side=>'left'); $knp->Button(-text=>'Sort by PR',-width=>'8',-font=>$ff,-command=>\sub{prsrt(split(/\n/,$acc->Contents))},-background=>$butcol)->pack(-side=>'left'); $knp->Button(-text=>'Check & PR all',-width=>'14',-font=>$ff,-command=>\sub{$a=0;@am=split(/\n/,$acc->Contents);$a++foreach@am;for(1..$thr){threads->create(\&do);}},-background=>$butcol)->pack(-side=>'left'); $knp->Button(-text=>'Save',-width=>'4',-font=>$ff,-command=>\&save,-background=>$butcol)->pack(-side=>'left'); $knp->Button(-text=>'Clean body',-width=>'10',-font=>$ff,-command=>\&cl,-background=>$butcol)->pack(-side=>'left'); $knp->Button(-text=>'Clean',-width=>'4',-font=>$ff,-command=>\&clean,-background=>$butcol)->pack(-side=>'left'); $knp->Button(-text=>'Export',-width=>'6',-font=>$ff,-command=>\&exp,-background=>$butcol)->pack(-side=>'left'); $knp->Button(-text=>'Add to base',-width=>'10',-font=>$ff,-command=>[\&save,'ad'],-background=>$butcol)->pack(-side=>'left'); $acc=$zone->Scrolled('Text',-scrollbars=>'se',-font=>'{Tahoma} 8 bold',-height=>33,-width=>145,-background=>$bgform,-foreground=>$focofo)->pack(-side=>'left'); &ins; MainLoop; sub save{chomp($x=$acc->Contents);open asd,">$name" and print asd$x if@_[0]ne'ad';open asd,">>$name" and print asd "\n$x" if@_[0]eq'ad';close asd;&cl;&ins;} sub cl{$acc->delete('1.0','end')} sub ins{open asd,"<$name";$acc->insert('end',$_)while<asd>;close asd;} sub clean{foreach(split(/\n/,$acc->Contents)){$acc->delete('1.0','2.0');$acc->insert('end',"$1\n")if~/(http:\/\/[^ ]*)/}} sub reset{&cl;&ins;} sub exp{my $itog;foreach(split(/\n/,$acc->Contents)){$itog.="$1 $2\n" if~/(http:\/\/[^ \/]*)[^ ]*(.*)/} my $bl=$typak->DialogBox(-title => 'Export....',-buttons => ["OK"]); $bl->geometry('400x410');$exp=$bl->Scrolled('Text',-scrollbars => 'e', -height=>25, -width=>75)->pack(); $exp->insert('end',$itog);$bl->Button(-text=>'Dump',-width =>'6',-font =>$ff,-background=>$butcol,-command=>\sub{open spl,">".$dum;print spl $exp->Contents;close spl;})->pack();$bl->Show();$bl->destroy;} sub do{while($a>0){$a-- and $sel=@am[$a];$it=ch($&) if $sel=~/http:\/\/[^ \n]*/; $it.=' '.pr($&) if $sel=~/http:\/\/[^ \n\/]*/;chomp($zi=$acc->Contents);chomp($sel);$zi=~s|$sel|$sel $it|;&cl; $acc->insert('end',$zi);}} sub ch{if($ua->head(@_[0])->as_string=~/200|401/){return '[OK]';} elsif($ua->head(@_[0])->as_string=~/500/){return 'Bad connect...';}else{return'[BAD]';}} sub pr{$k=@_[0]; if($ua->post("http://page-rank.org.ua/index.php",{'UrlList'=>$k,'CSV'=>'on'})->as_string=~/$k"[^\n]*/){ my $pr=$&;$pr=~s/$k",/PR=/;$pr=~s/PR=-1/PR=0/ig;return $pr;}else{return ' BAd pR';}} sub prsrt{undef@st;for($w=10;$w>=0;$w--){foreach$a(@_){push @st=>"$a\n" if $a=~/PR=$w/;}} foreach$a(@_){push@st=>"$a\n"if$a=~/PR=/ ne 1;}$acc->delete('1.0','end');$acc->insert('end',$_)foreach@st;} PS скачивайте на сайте в подписи
потестил, зачотно, только поправить пришлось Code: sub ch{if($ua->head(@_[0])->as_string=~/[B]401[/B]/){return '[OK]';}
perl - обрезаный тогдаб уже правил чтобы и без авторизации проканывало $ua->head(@_[0])->as_string=~/401/ or $ua->head(@_[0])->as_string=~/200/ я просто обычно не ставлю дык мне в голову чет не пришло это =))
можно так? $ua->head(@_[0])->as_string=~/401|200/ genom-- ActivePerl This is perl, v5.10.0 built for MSWin32-x86-multi-thread
genom-- оч.негативное впечатление .. совершенно не читаемый код .. Code: perldoc perlstyle поскольку написано под винду.. Code: $dum='C:\Documents and Settings\All Users\Рабочий стол\dump.txt'; # путь для дампа 1-ю строку стоит заменить на путь к интерпритатору Code: #!/usr/bin/perl Поскольку имеет роль только статус-лайн: Code: sub ch{if($ua->head(@_[0])->as_string=~/200 OK/){return '[OK]';} elsif($ua->head(@_[0])->as_string=~/500/){return 'Bad connect...';}else{return'[BAD]';}} можно подправить : Code: ...$ua->head(@_[0])->status_line eq '200 OK'# можно и рег.выраж. использывать еще много маленьких недочётов неохота их смотреть... Piflit Code: ppm install Tk
оч.негативное впечатление .. совершенно не читаемый код .. -- нехватает мозга не читай а мне так писать нравится ) поскольку написано под винду.. -- че сложно путь заменить куда будешь дампить?? 1-ю строку стоит заменить на путь к интерпритатору -- нахрена?? под активом они автоматом ассоциируются с ним при его установке $ua->head(@_[0])->status_line eq '200 OK' и $ua->head(@_[0])->as_string=~/200 OK/ - на два символа меньше - нафиг eq??? PS поправил на 401 и там и там
>> оч.негативное впечатление .. совершенно не читаемый код .. -- нехватает мозга не читай а мне так писать нравится ) мне кста тоже "не хватает мозга" читать твои кодесы.. MO=Deparse тока помогает.. ) этот кодес типа бывший priv8 from moa? +)
давай без оскорблений.я высказал свою критику . совсем неадекватный.. Code: $ua->head(@_[0])->as_string=~/200 OK/ - на два символа меньше - нафиг eq??? Code: as_string - в результате весь ответ status_line - в результате HTTP статус-лайн На 2 символа меньше , а трафика в сколько раз больше ? #пс я не буду дальше спорить..
demonoid посмотри снифером на сколько там меньше трафика, хотя можешь даже не утруждаться со снифером, выполни этот код и посмотри что будет use LWP::UserAgent; $ua = LWP::UserAgent->new(); $req = $ua->head('http://snapshot.opera.com/unix/snapshot-1719/x86_64-linux/opera_9.50-20071213.2-shared-qt_amd64.deb')->status_line; print $req; а вот ответ сервера нам, как видим трафика столько же, разница только в том что окажется в переменной HEAD /unix/snapshot-1719/x86_64-linux/opera_9.50-20071213.2-shared-qt_amd64.deb HTTP/1.1 Connection: close Host: snapshot.opera.com User-Agent: libwww-perl/5.805 HTTP/1.1 200 OK Date: Sun, 17 Feb 2008 19:44:42 GMT Server: Apache/2.2.3 (Debian) Last-Modified: Fri, 14 Dec 2007 15:00:27 GMT ETag: "440006-64a4f2-52a378c0" Accept-Ranges: bytes Content-Length: 6595826 Connection: close Content-Type: application/x-debian-package
Я чего-то не понял... это откуда ты такой вывод сделал? Ответ получается полностью в любом случае, а указанные методы лишь извлекают нужную информацию из него.
demonoid - ксурент совершенно прав я еще не забыл как он меня тыкнул в это лицом ))) ps - да и думаю у нас не так много шеллов чтобы напрягаться из-за трафика ps - никого не оскорблял просто заепся сення -- дык мб резко вырахаюсь пожтому )
короч добавил еще фичу - не многим наверное она понадобится - но мне надо вот и написал - короч внизу кода там по пиару идет расценовка шеллов в конец добаляется цена каждого и внизу выводится общая сумма за весь список закинул на сайт в подписи новую версию ой чуть не забыл жать кнопку ?$ на панели =)
