Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Perl: Системное программирование > Как удалить первую строку в файле?


Автор: Гость_Kris 18.11.2005, 13:27
Сабж - если файл разросся до слишком больших размеров требуется удалить первую
(соответственно самую старую) запись (строку).
Вопрос- можно ли это сделать не переписывая данные в массив или во временный файл?? smile

Автор: arto 18.11.2005, 13:45
нет

Автор: Kiber_rat 18.11.2005, 14:33
Вот пример... Массив не нужен, но временная переменная нужна smile
Код

#!/usr/bin/perl
use strict;
use warnings;
my $counter=0;
my $buf='';
open FD,"<testfile" or die;
while (<FD>){
    # переписав условие можно удалять сколько угодно строк от начала файла.
    $buf.=$_ if $counter++; 
} 
close FD; 
open FD, ">testfile" or die;
print FD $buf;

Автор: korob2001 18.11.2005, 14:45
А вообще это нужно изначально продумывать, ещё перед тем как файл разросся. Например держать в файле только последние 200 строк, всё остальные писать в архив. Допустим добавляется 201 строка, то первая выдёргивется и пишется в архив. Тогда можно и массивом воспользоваться. Кстати а строки какой длины? Может стоит подумать над тем что бы заюзать DBM?

Автор: Гость_Kris 18.11.2005, 16:03
Почему-то не работает (после первой записи 4 байт данные в файл не добавляются) smile
Строка запроса
http://www.host-n-one.com/cgi-bin/form.cgi?b=%ff%ff%ff%f0

Код

#!/usr/bin/perl

$counter=0;
$buf='';
$size=0;

#Get data --------
if ($ENV{'REQUEST_METHOD'} eq "POST")
    {
      read(STDIN, $bufer, $ENV{'CONTENT_LENGTH'});
    }
else
    {
      $bufer=$ENV{'QUERY_STRING'};
    }    

@pairs = split(/&/, $bufer);
foreach $pair (@pairs) {
   ($name, $value) = split(/=/, $pair);
   $value =~ tr/+/ /;
   $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
   $VOTE{$name} = $value;
}

$path="$ENV{'DOCUMENT_ROOT'}";
$filename=$path."/output/test.txt";
     
#See if file already exists --------

$test=0; 
if (-e("$filename")){ $size= -s $filename; }
else { $test=1;  } 

#If exists check it for duplicates --------

if ($test==0) {
open (NAMEFILE, "$filename");
 while(<NAMEFILE>)
{
 if (/$value/) { $test=0; break; }
}
close (NAMEFILE);
}
 
#If no duplicates found --------

if ($test==1)  {
#If file is too large delete first 4 bytes --------

if ($size>=12)  { 
open (NAMEFILE, "$filename"); 
sysread(NAMEFILE, &buf, $size-4, 4); 

close (NAMEFILE);
open (NAMEFILE, ">$filename"); 
flock (NAMEFILE, 2);
syswrite (NAMEFILE, $buf, $size-4, 0);
close (NAMEFILE);
$size-=4;
}
#Add new record --------

open (NAMEFILE, ">>$filename"); 
flock (NAMEFILE, 2);
print NAMEFILE $value;
close (NAMEFILE);
$size+=4;
}

Автор: Kiber_rat 18.11.2005, 19:15
А можно узнать что ты пытаешься сделать? Кроме того, почему не пользуешься модулем CGI? Пример который я писал годится для строк, а тебе, похоже, нужно побайтово работать, тогда используй seek что бы задать позицию с которой нужно читать. Вобщем опиши задачу, тогда будет легче написать пример.

Автор: Гость_Kris 18.11.2005, 20:40
Да собственно нужен такой массив каждый элемент в котором это четырехбайтовое число.
Массив хранится в файле и при достижении некоторого числа элементов, скажем 1000, самая старая (первая) запись просто стирается, а новая добавляется в конец этого массива.
Ну еще желательно проверять перед записью наличие элемента с таким значением в массиве-если имеется, то ничего не записываем и выходим.

Странно, но проверка вроде-бы работает, несмотря на то что строки файла собственно и не строки, а четырехбайтные числа....
Передаем число на сервер -> http://www.host-n-one.com/cgi-bin/form.cgi?record=%ff%12%21%ff
Код

$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
#$value=0xff1221ff;
#проверяем может такое уже есть....
open (NAMEFILE, "$filename");
 while(<NAMEFILE>)
{
 if (/$value/) { $bTest=0; break; }
}
close (NAMEFILE);



А вот убрать первую запись (если число элементов > n) из файла не получается smile

Я в Perl совсем зеленый , не знаю что в нем является строкой - m-байтная двоичная последовательность это строка? Или строка должна иметь какой-то символ ограничитель?
Какая минимальная длина строки? Максимальная? Может ли строка содержать любые символы от 00 до FF или нет?

Автор: sharq 19.11.2005, 00:07
Строка - это все что в кавычках двойных или одинаковых, число может использоваться тоже как строка, все зависит от контекста. Perl сам определяет строка здесь или число.
Никаких ограничителей у строки нет, только - размер оперативной памяти. smile
Минимальная длина строки - длина пустой строки = 0.

Цитата
Может ли строка содержать любые символы от 00 до FF или нет?

да, строка может содержать все что угодно, на то она и строка.

smile

Автор: korob2001 19.11.2005, 00:28
Файл открывай как для чтения, так и для записи. Читай блоками байтов, а не строками. Вот тебе пример c коментариями.
Только в данном случае параметр получаем из командной строки, это я сделал для более легкого тестирования.
Код

#!/usr/bin/perl -w
use strict;

# Имя файла, с которым будем работать
my $file = "test.txt";
# Получаем рараметр из командной строки
chomp(my $param = shift);
# Флаг, по нему будем определять есть ли такая строка в файле
my $flag = 0;
# Максимальное кол-во блоков, т.е. записей в файле
my $max_block = 5;
# Длана блока в байтах
my $block_length = 4;
my @bytes = ();
my $buff;

# Отарываем файл для чтения и записи
open(F, "+< $file") or die "Can't open file: $!\n";

# Следующая строка нужна только для винды, но под
# никсами она ничего не делает потому указываем её
# в любом случае для переносимости
binmode F;

# Можно было этого и не делать, переходим в начало файла
seek(F, 0, 0);

# Читаем файл блоками по $block_length байт
while ( read( F, $buff, $block_length ) ) {
        # Распаковуем полученные байты в строку и
        # сравниваем её с полученной из командной строки
        if ( unpack("a$block_length",$buff) eq $param ) {
             # Если оказались здесь, значит такая запись есть в файле
             # устанавливаем флаг и завершаем цикл, как я понял делать
             # в этом случае ничего не нужно
             $flag = 1;
             last;
        }
        # Сохраняем в массив полученный блок
        push(@bytes, $buff);
}

# Проверяем был ли установлен флаг, если нет то:
unless ( $flag ) {
      # переходим в начало файла если текущая позиция / $block_length больше $max_block
      if ((tell() / $block_length) >= $max_block ) {
           seek(F,0,0);  # Переходим в начало
           # Удаляем первый элемент
           shift @bytes;
           # Добавляем новый в конец, перед этим упакуем его
           push(@bytes, pack("a$block_length", $param));
           # Перезаписываем файл
           print F $_ while ($_ = shift @bytes);
      } else {
            # Упакуем строку и добавим в файл
            print F pack("a$block_length", "$param");
      }
}

close(F);

Только +< не создаёт файла, потому тебе нужно будет создать, пустой, файл самому. Затем настрой первые 3 переменные. Из командной строки передавай параметр:
C:\>perl test.pl ffff
C:\>perl test.pl xxxx
C:\>perl test.pl aaaa
И так далее.
В файле будет сохранено максимум $max_block блоков, если если блоков больше или равно, то первая запись будет удалена, а новая запись будет добавлена в конец.
Если переданный параметр уже есть, то он не будет сохранён повторно.
Я не блокировал файл, но в конечной программе это нужно будет сделать.

Не знаю это то, что тебе нужно или нет. Вобщем пробуй. Если что-то будет не ясно, пиши.

Автор: Kiber_rat 19.11.2005, 02:53
По порядку. Строкой, при чтении из файла по крайней мере, считается последовательность символов ограниченная символом перевода строки (\n). Далее, то что ты хочешь хранить в этом файле? Я так понимаю что это двоичные данные?
А насколько критично их писать не на одной строке? Добавляй перевод строки и все будет работать. А еще лучше хранить это в dbm файле. Доступ будет проще и быстрее. И используй модуль CGI, он тебе сильно жизнь облегчит. Да и массив тебе ничем не мешает, скорее наоборот smile
Код

#!/usr/bin/perl
#Crafted by Ku6ep :)
use strict;
use warnings;
use CGI;
my %Q = CGI::Vars();
my $LIMIT=10; # макс. кол-во элементов
my @buf;
my $file = 'data/outfile';
print CGI::header();
die "Don't get variable!\n" unless $Q{value}; # Умереть если не передана value
if (-e $file){
    open FR,"<$file" or die "Can't open file, $!";
    while (<FR>) {
        chomp;
        push (@buf,$_);
        if (/^$Q{value}/) {
            print "Data exists!";
            exit; 
        }
    }
    shift @buf if @buf >= $LIMIT;
}
push(@buf, $Q{value}); 
open FO,">$file" or die "Can't open file, $!";
print FO "$_\n" for @buf; # Добавляем перевод строки к каждой записи
close FO;
print "Data added...";

Проверь, может подойдет smile
P.S. Увидел ответы после того как написал smile Так что у тебя теперь есть из чего составить нужный тебе скрипт...

Автор: Kiber_rat 19.11.2005, 03:40
Вот, еще один вариант, так сказать "компиляция советов" smile
Код

#!/usr/bin/perl
use strict;
use warnings;
use CGI;
my %Q = CGI::Vars();
die "Don't get variable!\n" unless $Q{value}; # Умереть если не передана value
my $LIMIT=10; # макс. кол-во элементов
my $datalengh=4; # длина одной записи
my (@buf, $buff);
my $file = 'data/outfile_bin';
print CGI::header();
if (!-e $file) { # Создать файл если не было...
    open FH, "> :raw",$file;
    print FH pack("a$datalengh",$Q{value}); # ...записать в него данные...
    close FH;
    print "Data added...";
    exit; #... и выйти
}
open FH, "+< :raw",$file or die "Can't open file, $!"; # :raw - вместо binmode :)
while (read(FH,$buff,$datalengh)) {
    if (unpack("a$datalengh",$buff) eq $Q{value}) {
        print "Data exists!";
        exit;
    }
    push (@buf,$buff);
}
shift @buf if @buf >= $LIMIT;
push(@buf, pack("a$datalengh",$Q{value}));
seek(FH,0,0);
print FH for @buf;
close FH;
print "Data added...";

Автор: Guest 19.11.2005, 16:28
Ураааа! Работает smile Пасибо огромное всем за помощь!
Не уверен насчет flock(), говорят это срабатывает не во всех случаях,
еще не получилось открыть файл с ключом :raw - Unknown open mode!
а в остальном вот наваял по вашим советамsmile

Код

#!/usr/bin/perl
use strict;
#use warnings;

my $value = shift(@ARGV); # берет командную строку

my $LIMIT=10; # макс. кол-во элементов
my $datalengh=4; # длина одной записи
my (@buf, $buff);
my $file="test.txt";
my $flag = 0;


if (!-e $file) { # Создать файл если не было...
    open FH, ">$file";
    binmode FH;
    print FH pack("a$datalengh",$value);     # записать в него данные...
    close (FH);
    #print "Data added...";
    exit(0); 
}

# Отkрываем файл для чтения и записи
 open FH, "+<$file";        # Unknown open mode!!! if open FH, "+< :raw"; вместо binmode :)
 flock (FH, 2);
 binmode FH;
 seek(FH, 0, 0);

# Читаем файл блоками по $block_length байт
 while (read(FH,$buff,$datalengh)) {
    if (unpack("a$datalengh",$buff) eq $value) {
        #print "Data exists!";
        #exit;
       $flag = 1;
       last;
    }
    push (@buf,$buff);    # Сохраняем в массив полученный блок    
}

# Проверяем был ли установлен флаг, если нет то:
unless ( $flag ) {
shift @buf if @buf >= $LIMIT;
push(@buf, pack("a$datalengh",$value));
seek(FH,0,0);
print FH for @buf;
}
flock (FH, 0);
close FH;

Автор: korob2001 20.11.2005, 08:28
Вообще-то, было бы не плохо проверять файл не только на существование, но так же и на то, что он является двоичным.
Код

# Удаляем файл если он существует и не является двоичным
unlink $file if ( (-e $file) and (!-B $file) );
unless ( -e $file ) {
              # Файл не существует
} else {
              # Существует, а так же он двоичный
}

Но это уже тонкости. smile

Автор: Гость_Kris 20.11.2005, 11:16
Еще выяснилось что паковать надо с флагом Н8, иначе данные сохраняются как строка символов. а не двоичное числоsmile
Для оптимизации поиска ввел дополнительную переменную, чтобы не распаковывать в цикле.

Код

my $bin_a=pack("H8",$value);
####################

 while (read(FH,$buff,$datalengh)) {

    if ($buff eq $bin_a) {
       $flag = 1;
       last;
    }
    push (@buf,$buff);    
}

Автор: korob2001 20.11.2005, 23:14
a - Строка байт, дополняемая нулями
H - Шестнадцатиричная строка, старший полубайт впереди.

Автор: Guest 21.11.2005, 13:44
Добавил еще переменную (она же флаг). Теперь можно не только добавить строчку, но и удалить и модифицировать любую строкуsmile
Интересно, а можно сделатьтак чтобы одномоментно выполнялась только одна копия процесса?
Может ли сервак поставить запрос к скрипту в очередь?

Код

#!/usr/bin/perl
use strict;

my $pair;
my $name;
                  # 1 new record - (фиксированные значения для отладки)
my $bufer="q=%39%37%62%38%65%64%35%33&d=%30%30%30%30%30%30%30%30";
                  # 2 modify
#my $bufer="q=%39%37%62%38%65%64%35%33&d=%29%27%22%28%25%24%25%23";
                  # 3 delete
#my $bufer="q=%30%30%30%30%30%30%30%30&d=%29%27%22%28%25%24%25%23";

my $value;
my @pairs = split(/&/, $bufer);
my $step=0;
my @params;
foreach $pair (@pairs) {
   ($name, $value) = split(/=/, $pair);
   $value =~ tr/+/ /;
   $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
   $params[$step] = $value;
   $step++;
 print "name: $name value: $value  step: $step", "\n";
}
   my $zero=pack("H8","00000000");

my $bin_a=pack("H8",$params[0]);
my $bin_b=pack("H8",$params[1]);
 $value=unpack("H8",$bin_a);  print "bin_a= $value", "\n";
 $value=unpack("H8",$bin_b);  print "bin_b= $value", "\n";


my $LIMIT=10;
my $datalengh=4;
my (@buf, $buff);
my $file="test.bin";
my $flag = 0;


if (!-e $file) {  
    open FH, ">$file";
    binmode FH;
    print FH $bin_a;     
    close (FH);
    exit(0); 
}

 open FH, "$file";    
 flock (FH, 1);
 binmode FH;   
 seek(FH, 0, 0);

 while (read(FH,$buff,$datalengh)) {
 if (($bin_a eq $zero) && ($bin_b ne $zero)) {       #delete
 if ($buff ne $bin_b)  { push (@buf,$buff); }
     next;  }
 if (($bin_a ne $zero) && ($bin_b ne $zero)) {       #modify
 if ($buff eq $bin_a)   { $buff=$bin_b; }   
    push (@buf,$buff); next;  }
 if (($bin_a ne $zero) && ($bin_b eq $zero)) {       #add record
    if ($buff eq $bin_a) { $flag = 1;  last; }
    push (@buf,$buff);   } 
}
 flock (FH, 0);
 close FH;

unless ( $flag ) {
shift @buf if @buf >= $LIMIT;
 if (($bin_a ne $zero) && ($bin_b eq $zero)) { push(@buf, $bin_a); }
 open FH, ">$file"; 
 flock (FH, 2); binmode FH;   
 seek(FH,0,0);
 print FH for @buf;
 flock (FH, 0);  close FH;
}

Автор: korob2001 21.11.2005, 22:53
Создай блокировку на другой файл, пусть на нём и создаётся очередь. Например:
Код

#!/usr/bin/perl
use strict;
use Fcntl qw( :flock );

# блокируем код, вся очередь будет стоять здесь
start_lock();

# Вместо следующих трёх строк твой код, к которому будет создаваться очередь
print "Please enter your name: ";
chomp( my $name = <STDIN> );
print "Hello $name\n";

# Закрываем блокировку и завершаем выполнение программы
stop_lock();
exit 0;

sub start_lock {
       open( BLOCK, "> semaphor.sem" ) or die "Can't open block file: $!\n";
       flock( BLOCK, LOCK_EX ) or die "Can't locked file: $!\n";
}

sub stop_lock {
       close(BLOCK);
}

Теперь сохрани всё это дело и попробуй запустить из командной строки. Запусти второй сеанс командной строки и запусти тот же файл. После в одном ты видишь запрос на ввод имени, во втором ничего, так как ожидает в очереди. Теперь в первом введи своё имя и нажми enter, в первом ты увидешь приветствие, а во втором появится запрос на вод имени, так как подошла его очередь. Получается мы блокируем часть кода. Всё что находится между вызовами подпрограмм start_lock() и stop_lock() будет забокированно. Очередь создаётся в том месте, где была вызвана подпрограмма start_lock().

Автор: Гость_Kris 22.11.2005, 14:28
А зачем здесь использовать модуль Fcntl?
Вот такой код тоже вроде нормально работает smile

Код

#!/usr/bin/perl
use strict;

my $tempfile="semaphor.sem";
# блокируем код, вся очередь будет стоять здесь
start_lock();

# Вместо следующих трёх строк твой код, к которому будет создаваться очередь
print "Please enter your name: ";
chomp( my $name = <STDIN> );
print "Hello $name\n";

# Закрываем блокировку и завершаем выполнение программы
stop_lock();
exit 0;

sub start_lock {
       open( BLOCK, "> $tempfile" ) or die "Can't open block file: $!\n";
       flock( BLOCK, 2 ) or die "Can't locked file: $!\n";
}

sub stop_lock {
       unlink $tempfile;
       close(BLOCK);
}

Автор: korob2001 22.11.2005, 15:03
Ну это уже дело вкуса, лично я пользуюсь всегда Fcntl, тем более он входит в стандартыный пакет. Смысл был не в Fcntl, а в том как создать очередь с помощью блокировки.

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)