Perl: поиск и замена в цикле foreach

Question

возможно, кто-то может мне помочь. Мне нужно выполнить поиск и заменить на заданную строку, найти любую информацию из одного из списка вещей и вставить в нее возврат каретки.

Я предоставляю образец строки и мою попытку решить проблему.

Пример ввода:

MSH|^~\&|PCM|A|NSG|A|20120613081122|DoNotBundle|ORM^O01|1133316|P|2.2|||AL|NEPID|1|1234567^PI^PE|345235^ST02A^MR^A~02340395^ST02^PI||HSM^AERHART||19510418000000|F||||||||||1215200001^A|111-22-3333 
PV1|1|I|CCU^W207^A^A||||12342^ALI^ROGERS^M^MD^MD|||SUR|||||||16532^ALI^ROGERS^M^MD^MD|INP||B|||||||||||||||||||A|||||20120531145230ORC|PA|11109489^PCM|11109489^PCM|94986|SC||1^Continuous^INDEF^20120613081900^1||20120613081958|RGYIDDER^YIDDER^ROBERT^GSYSTEM ADM^SA||16532^ALI^ROGERS^MMD^MD|CCU||20120613081958|||CCU|RGYIDDER^YIDDER^ROBERT^ 
G^SYSTEM ADM^SA 
OBR|1|11109489^PCM|11109489^PCM|DNR ON^Hard of Hearing^NSG||20120613081122||||||||||16532^ALI^ROGERS^M^MD^MD|||||||||||1^Continuous^INDEF^20120613081900^1 

И моя попытка:

$/ = undef;   #tells perl to ignore newlines when reading input 
$input = <STDIN>; #read entire input into $input 

$input =~ s/\R/ /g; #remove all newlines from input. \R matches \r, \n, \r\n 

@validSegHdrs = ( "ABS", "ACC", "ADD", "ADJ", "AFF", "AIG", "AIL", "AIP", "AIS", "AL1", 
        "APR", "ARQ", "ACC", "ADD", "ADJ", "AFF", "AIG", "AIL", "AIP", "AIS", 
        "AL1", "APR", "ARQ", "ARV", "AUT", "BHS", "BLC", "BLG", "BPO", "BPX", 
        "BTS", "BTX", "CDM", "CER", "CM0", "CM1", "CM2", "CNS", "CON", "CSP", 
        "CSR", "CSS", "CTD", "CTI", "DB1", "DG1", "DMI", "DRG", "DSC", "DSP", 
        "ECD", "ECR", "EDU", "EQP", "EQU", "ERR", "EVN", "FAC", "FHS", "FT1", 
        "FTS", "GOL", "GP1", "GP2", "GT1", "IAM", "IIM", "ILT", "IN1", "IN2", 
        "IN3", "INV", "IPC", "IPR", "ISD", "ITM", "IVC", "IVT", "LAN", "LCC", 
        "LCH", "LDP", "LOC", "LRL", "MFA", "MFE", "MFI", "MRG", "MSA", "MSH", 
        "NCK", "NDS", "NK1", "NPU", "NSC", "NST", "NTE", "OBR", "OBX", "ODS", 
        "ODT", "OM1", "OM2", "OM3", "OM4", "OM5", "OM6", "OM7", "ORC", "ORG", 
        "OVR", "PCE", "PCR", "PD1", "PDA", "PDC", "PEO", "PES", "PID", "PKG", 
        "PMT", "PR1", "PRA", "PRB", "PRC", "PRD", "PSG", "PSH", "PSL", "PSS", 
        "PTH", "PV1", "PV2", "PYE", "QAK", "QID", "QPD", "QRD", "QRF", "QRI", 
        "RCP", "RDF", "RDT", "REL", "RF1", "RFI", "RGS", "RMI", "ROL", "RQ1", 
        "RQD", "RXA", "RXC", "RXD", "RXE", "RXG", "RXO", "RXR", "SAC", "SCD", 
        "SCH", "SCP", "SDD", "SFT", "SID", "SLT", "SPM", "STF", "STZ", "TCC", 
        "TCD", "TQ1", "TQ2", "TXA", "UAC", "UB1", "UB2", "URD", "URS", "VAR", 
        "VND" 
); 

foreach (@validSegHdrs) { 
    $input =~ s/$_/\r$_/g; 
} 

print $input; 

-

Для чего это стоит, я работаю с HL7. HL7 состоит из «сегментов» каждый на своей собственной линии. Сегмент, начинающийся с «MSH», всегда первый, и должен быть возврат каретки, предшествующий каждому дополнительному сегменту.

Мой вход может иметь разрывы строк (или возврат каретки) в середине сегмента, что недопустимо. Я также могу встретить новый сегмент, начинающийся в той же строке, что и другой, что также не допускается.

Я собираюсь разобрать вход, сначала разбить все разрывы строк и найти любые совпадения допустимых заголовков сегментов и вставить перед ними возврат каретки. Я определил массив со всеми допустимыми заголовками сегментов, и я пытаюсь использовать цикл foreach для простого поиска и замены, чтобы вставить \ r перед каждым совпадением. Я думаю, что может быть хорошей идеей для каждой строки плюс '|', например, матч на 'PV1 |' точнее.

Я не получаю ожидаемый результат, поэтому я смиренно прошу знаний. Большое спасибо!

Answer 1

Я использовал этот скрипт из командной строки:

perl -e 'print "\n"; local $/; $in=<>; $in=~s/\R//g; my @blk = qw(ABS ACC ADD ADJ AFF AIG AIL AIP AIS AL1 APR ARQ ACC ADD ADJ AFF AIG AIL AIP AIS AL1 APR ARQ ARV AUT BHS BLC BLG BPO BPX BTS BTX CDM CER CM0 CM1 CM2 CNS CON CSP CSR CSS CTD CTI DB1 DG1 DMI DRG DSC DSP ECD ECR EDU EQP EQU ERR EVN FAC FHS FT1 FTS GOL GP1 GP2 GT1 IAM IIM ILT IN1 IN2 IN3 INV IPC IPR ISD ITM IVC IVT LAN LCC LCH LDP LOC LRL MFA MFE MFI MRG MSA MSH NCK NDS NK1 NPU NSC NST NTE OBR OBX ODS ODT OM1 OM2 OM3 OM4 OM5 OM6 OM7 ORC ORG OVR PCE PCR PD1 PDA PDC PEO PES PID PKG PMT PR1 PRA PRB PRC PRD PSG PSH PSL PSS PTH PV1 PV2 PYE QAK QID QPD QRD QRF QRI RCP RDF RDT REL RF1 RFI RGS RMI ROL RQ1 RQD RXA RXC RXD RXE RXG RXO RXR SAC SCD SCH SCP SDD SFT SID SLT SPM STF STZ TCC TCD TQ1 TQ2 TXA UAC UB1 UB2 URD URS VAR VND); $in=~s/$_/\n$_/ for @blk; print $in, "\n";' 

И получил этот результат:

MSH|^~\&|PCM|A|NSG|A|20120613081122|DoNotBundle|ORM^O01|1133316|P|2.2|||AL|NE 
PID|1|1234567^PI^PE|345235^ST02A^MR^A~02340395^ST02^PI||HSM^AERHART||19510418000000|F||||||||||1215200001^A|111-22-3333 
PV1|1|I|CCU^W207^A^A||||12342^ALI^ROGERS^M^MD^MD|||SUR|||||||16532^ALI^ROGERS^M^MD^MD|INP||B|||||||||||||||||||A|||||20120531145230 
ORC|PA|11109489^PCM|11109489^PCM|94986|SC||1^Continuous^INDEF^20120613081900^1||20120613081958|RGYIDDER^YIDDER^ROBERT^GSYSTEM  ADM^SA||16532^ALI^ROGERS^MMD^MD|CCU||20120613081958|||CCU|RGYIDDER^YIDDER^ROBERT^G^SYSTEM  ADM^SA 
OBR|1|11109489^PCM|11109489^PCM|DNR ON^Hard of Hearing^NSG||20120613081122||||||||||16532^ALI^ROGERS^M^MD^MD|||||||||||1^Continuous^INDEF^20120613081900^1 

Если сценарий был написан с отступом, он будет выглядеть следующим образом:

local $/; 
$in=<>; 
$in=~s/\R//g; 
my @blk = qw(
    ABS ACC ADD ADJ AFF AIG AIL AIP AIS AL1 APR ARQ ACC ADD ADJ AFF AIG AIL AIP 
    AIS AL1 APR ARQ ARV AUT BHS BLC BLG BPO BPX BTS BTX CDM CER CM0 CM1 CM2 CNS 
    CON CSP CSR CSS CTD CTI DB1 DG1 DMI DRG DSC DSP ECD ECR EDU EQP EQU ERR EVN 
    FAC FHS FT1 FTS GOL GP1 GP2 GT1 IAM IIM ILT IN1 IN2 IN3 INV IPC IPR ISD ITM 
    IVC IVT LAN LCC LCH LDP LOC LRL MFA MFE MFI MRG MSA MSH NCK NDS NK1 NPU NSC 
    NST NTE OBR OBX ODS ODT OM1 OM2 OM3 OM4 OM5 OM6 OM7 ORC ORG OVR PCE PCR PD1 
    PDA PDC PEO PES PID PKG PMT PR1 PRA PRB PRC PRD PSG PSH PSL PSS PTH PV1 PV2 
    PYE QAK QID QPD QRD QRF QRI RCP RDF RDT REL RF1 RFI RGS RMI ROL RQ1 RQD RXA 
    RXC RXD RXE RXG RXO RXR SAC SCD SCH SCP SDD SFT SID SLT SPM STF STZ TCC TCD 
    TQ1 TQ2 TXA UAC UB1 UB2 URD URS VAR VND); 
$in=~s/$_/\n$_/ for @blk; 
print $in, "\n"; 

Вы бы заменили \n на \r Я думаю.

Я не знаю, какова реальная разница между нашими скриптами, но это работает для меня ??

Обратите внимание, что использование хэша может быть более эффективным (О (п) → O (1), где п этого числа последовательностей заголовка):

my %hash = map {$_ => 1} @blk; 
# Test if $1 is a header sequence, if so, print newline 
$in =~ s/([A-Z0-9]{3})/ $hash{$1} ? "\n$1" : $1 /xeg; 

Answer 2

@validSegHdrs = ( "ABS", # ..... 
); 

my $regex = join ("|", @validSegHdrs); 
while (<>) { 
    s/\R/ /g; 
    s/($regex)/\r$1/g; 
    print; 
}