gnus-agent.el 159 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246
  1. ;;; gnus-agent.el --- unplugged support for Gnus
  2. ;; Copyright (C) 1997-2012 Free Software Foundation, Inc.
  3. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
  4. ;; This file is part of GNU Emacs.
  5. ;; GNU Emacs is free software: you can redistribute it and/or modify
  6. ;; it under the terms of the GNU General Public License as published by
  7. ;; the Free Software Foundation, either version 3 of the License, or
  8. ;; (at your option) any later version.
  9. ;; GNU Emacs is distributed in the hope that it will be useful,
  10. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. ;; GNU General Public License for more details.
  13. ;; You should have received a copy of the GNU General Public License
  14. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  15. ;;; Commentary:
  16. ;;; Code:
  17. (require 'gnus)
  18. (require 'gnus-cache)
  19. (require 'nnmail)
  20. (require 'nnvirtual)
  21. (require 'gnus-sum)
  22. (require 'gnus-score)
  23. (require 'gnus-srvr)
  24. (require 'gnus-util)
  25. (eval-when-compile
  26. (if (featurep 'xemacs)
  27. (require 'itimer)
  28. (require 'timer))
  29. (require 'cl))
  30. (autoload 'gnus-server-update-server "gnus-srvr")
  31. (autoload 'gnus-agent-customize-category "gnus-cus")
  32. (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
  33. "Where the Gnus agent will store its files."
  34. :group 'gnus-agent
  35. :type 'directory)
  36. (defcustom gnus-agent-plugged-hook nil
  37. "Hook run when plugging into the network."
  38. :group 'gnus-agent
  39. :type 'hook)
  40. (defcustom gnus-agent-unplugged-hook nil
  41. "Hook run when unplugging from the network."
  42. :group 'gnus-agent
  43. :type 'hook)
  44. (defcustom gnus-agent-fetched-hook nil
  45. "Hook run when finished fetching articles."
  46. :version "22.1"
  47. :group 'gnus-agent
  48. :type 'hook)
  49. (defcustom gnus-agent-handle-level gnus-level-subscribed
  50. "Groups on levels higher than this variable will be ignored by the Agent."
  51. :group 'gnus-agent
  52. :type 'integer)
  53. (defcustom gnus-agent-expire-days 7
  54. "Read articles older than this will be expired.
  55. If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'."
  56. :group 'gnus-agent
  57. :type '(number :tag "days"))
  58. (defcustom gnus-agent-expire-all nil
  59. "If non-nil, also expire unread, ticked and dormant articles.
  60. If nil, only read articles will be expired."
  61. :group 'gnus-agent
  62. :type 'boolean)
  63. (defcustom gnus-agent-group-mode-hook nil
  64. "Hook run in Agent group minor modes."
  65. :group 'gnus-agent
  66. :type 'hook)
  67. ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  68. (when (featurep 'xemacs)
  69. (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add))
  70. (defcustom gnus-agent-summary-mode-hook nil
  71. "Hook run in Agent summary minor modes."
  72. :group 'gnus-agent
  73. :type 'hook)
  74. ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  75. (when (featurep 'xemacs)
  76. (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add))
  77. (defcustom gnus-agent-server-mode-hook nil
  78. "Hook run in Agent summary minor modes."
  79. :group 'gnus-agent
  80. :type 'hook)
  81. ;; Extracted from gnus-xmas-redefine in order to preserve user settings
  82. (when (featurep 'xemacs)
  83. (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add))
  84. (defcustom gnus-agent-confirmation-function 'y-or-n-p
  85. "Function to confirm when error happens."
  86. :version "21.1"
  87. :group 'gnus-agent
  88. :type 'function)
  89. (defcustom gnus-agent-synchronize-flags nil
  90. "Indicate if flags are synchronized when you plug in.
  91. If this is `ask' the hook will query the user."
  92. ;; If the default switches to something else than nil, then the function
  93. ;; should be fixed not be exceedingly slow. See 2005-09-20 ChangeLog entry.
  94. :version "21.1"
  95. :type '(choice (const :tag "Always" t)
  96. (const :tag "Never" nil)
  97. (const :tag "Ask" ask))
  98. :group 'gnus-agent)
  99. (defcustom gnus-agent-go-online 'ask
  100. "Indicate if offline servers go online when you plug in.
  101. If this is `ask' the hook will query the user."
  102. :version "21.3"
  103. :type '(choice (const :tag "Always" t)
  104. (const :tag "Never" nil)
  105. (const :tag "Ask" ask))
  106. :group 'gnus-agent)
  107. (defcustom gnus-agent-mark-unread-after-downloaded t
  108. "Indicate whether to mark articles unread after downloaded."
  109. :version "21.1"
  110. :type 'boolean
  111. :group 'gnus-agent)
  112. (defcustom gnus-agent-download-marks '(download)
  113. "Marks for downloading."
  114. :version "21.1"
  115. :type '(repeat (symbol :tag "Mark"))
  116. :group 'gnus-agent)
  117. (defcustom gnus-agent-consider-all-articles nil
  118. "When non-nil, the agent will let the agent predicate decide
  119. whether articles need to be downloaded or not, for all articles. When
  120. nil, the default, the agent will only let the predicate decide
  121. whether unread articles are downloaded or not. If you enable this,
  122. groups with large active ranges may open slower and you may also want
  123. to look into the agent expiry settings to block the expiration of
  124. read articles as they would just be downloaded again."
  125. :version "22.1"
  126. :type 'boolean
  127. :group 'gnus-agent)
  128. (defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb
  129. "Chunk size for `gnus-agent-fetch-session'.
  130. The function will split its article fetches into chunks smaller than
  131. this limit."
  132. :version "22.1"
  133. :group 'gnus-agent
  134. :type 'integer)
  135. (defcustom gnus-agent-enable-expiration 'ENABLE
  136. "The default expiration state for each group.
  137. When set to ENABLE, the default, `gnus-agent-expire' will expire old
  138. contents from a group's local storage. This value may be overridden
  139. to disable expiration in specific categories, topics, and groups. Of
  140. course, you could change gnus-agent-enable-expiration to DISABLE then
  141. enable expiration per categories, topics, and groups."
  142. :version "22.1"
  143. :group 'gnus-agent
  144. :type '(radio (const :format "Enable " ENABLE)
  145. (const :format "Disable " DISABLE)))
  146. (defcustom gnus-agent-expire-unagentized-dirs t
  147. "*Whether expiration should expire in unagentized directories.
  148. Have gnus-agent-expire scan the directories under
  149. \(gnus-agent-directory) for groups that are no longer agentized.
  150. When found, offer to remove them."
  151. :version "22.1"
  152. :type 'boolean
  153. :group 'gnus-agent)
  154. (defcustom gnus-agent-auto-agentize-methods nil
  155. "Initially, all servers from these methods are agentized.
  156. The user may remove or add servers using the Server buffer.
  157. See Info nodes `(gnus)Server Buffer', `(gnus)Agent Variables'."
  158. :version "22.1"
  159. :type '(repeat symbol)
  160. :group 'gnus-agent)
  161. (defcustom gnus-agent-queue-mail t
  162. "Whether and when outgoing mail should be queued by the agent.
  163. When `always', always queue outgoing mail. When nil, never
  164. queue. Otherwise, queue if and only if unplugged."
  165. :version "22.1"
  166. :group 'gnus-agent
  167. :type '(radio (const :format "Always" always)
  168. (const :format "Never" nil)
  169. (const :format "When unplugged" t)))
  170. (defcustom gnus-agent-prompt-send-queue nil
  171. "If non-nil, `gnus-group-send-queue' will prompt if called when unplugged."
  172. :version "22.1"
  173. :group 'gnus-agent
  174. :type 'boolean)
  175. (defcustom gnus-agent-article-alist-save-format 1
  176. "Indicates whether to use compression(2), versus no
  177. compression(1), when writing agentview files. The compressed
  178. files do save space but load times are 6-7 times higher. A group
  179. must be opened then closed for the agentview to be updated using
  180. the new format."
  181. ;; Wouldn't symbols instead numbers be nicer? --rsteib
  182. :version "22.1"
  183. :group 'gnus-agent
  184. :type '(radio (const :format "Compressed" 2)
  185. (const :format "Uncompressed" 1)))
  186. ;;; Internal variables
  187. (defvar gnus-agent-history-buffers nil)
  188. (defvar gnus-agent-buffer-alist nil)
  189. (defvar gnus-agent-article-alist nil
  190. "An assoc list identifying the articles whose headers have been fetched.
  191. If successfully fetched, these headers will be stored in the group's overview
  192. file. The key of each assoc pair is the article ID, the value of each assoc
  193. pair is a flag indicating whether the identified article has been downloaded
  194. \(gnus-agent-fetch-articles sets the value to the day of the download).
  195. NOTES:
  196. 1) The last element of this list can not be expired as some
  197. routines (for example, get-agent-fetch-headers) use the last
  198. value to track which articles have had their headers retrieved.
  199. 2) The function `gnus-agent-regenerate' may destructively modify the value.")
  200. (defvar gnus-agent-group-alist nil)
  201. (defvar gnus-category-alist nil)
  202. (defvar gnus-agent-current-history nil)
  203. (defvar gnus-agent-overview-buffer nil)
  204. (defvar gnus-category-predicate-cache nil)
  205. (defvar gnus-category-group-cache nil)
  206. (defvar gnus-agent-spam-hashtb nil)
  207. (defvar gnus-agent-file-name nil)
  208. (defvar gnus-agent-send-mail-function nil)
  209. (defvar gnus-agent-file-coding-system 'raw-text)
  210. (defvar gnus-agent-file-loading-cache nil)
  211. (defvar gnus-agent-total-fetched-hashtb nil)
  212. (defvar gnus-agent-inhibit-update-total-fetched-for nil)
  213. (defvar gnus-agent-need-update-total-fetched-for nil)
  214. ;; Dynamic variables
  215. (defvar gnus-headers)
  216. (defvar gnus-score)
  217. ;; Added to support XEmacs
  218. (eval-and-compile
  219. (unless (fboundp 'directory-files-and-attributes)
  220. (defun directory-files-and-attributes (directory
  221. &optional full match nosort)
  222. (let (result)
  223. (dolist (file (directory-files directory full match nosort))
  224. (push (cons file (file-attributes file)) result))
  225. (nreverse result)))))
  226. ;;;
  227. ;;; Setup
  228. ;;;
  229. (defun gnus-open-agent ()
  230. (setq gnus-agent t)
  231. (gnus-agent-read-servers)
  232. (gnus-category-read)
  233. (gnus-agent-create-buffer)
  234. (add-hook 'gnus-group-mode-hook 'gnus-agent-mode)
  235. (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode)
  236. (add-hook 'gnus-server-mode-hook 'gnus-agent-mode))
  237. (defun gnus-agent-create-buffer ()
  238. (if (gnus-buffer-live-p gnus-agent-overview-buffer)
  239. t
  240. (setq gnus-agent-overview-buffer
  241. (gnus-get-buffer-create " *Gnus agent overview*"))
  242. (with-current-buffer gnus-agent-overview-buffer
  243. (mm-enable-multibyte))
  244. nil))
  245. (gnus-add-shutdown 'gnus-close-agent 'gnus)
  246. (defun gnus-close-agent ()
  247. (setq gnus-category-predicate-cache nil
  248. gnus-category-group-cache nil
  249. gnus-agent-spam-hashtb nil)
  250. (gnus-kill-buffer gnus-agent-overview-buffer))
  251. ;;;
  252. ;;; Utility functions
  253. ;;;
  254. (defmacro gnus-agent-with-refreshed-group (group &rest body)
  255. "Performs the body then updates the group's line in the group
  256. buffer. Automatically blocks multiple updates due to recursion."
  257. `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body)
  258. (when (and gnus-agent-need-update-total-fetched-for
  259. (not gnus-agent-inhibit-update-total-fetched-for))
  260. (with-current-buffer gnus-group-buffer
  261. (setq gnus-agent-need-update-total-fetched-for nil)
  262. (gnus-group-update-group ,group t)))))
  263. (defun gnus-agent-read-file (file)
  264. "Load FILE and do a `read' there."
  265. (with-temp-buffer
  266. (ignore-errors
  267. (nnheader-insert-file-contents file)
  268. (goto-char (point-min))
  269. (read (current-buffer)))))
  270. (defsubst gnus-agent-method ()
  271. (concat (symbol-name (car gnus-command-method)) "/"
  272. (if (equal (cadr gnus-command-method) "")
  273. "unnamed"
  274. (cadr gnus-command-method))))
  275. (defsubst gnus-agent-directory ()
  276. "The name of the Gnus agent directory."
  277. (nnheader-concat gnus-agent-directory
  278. (nnheader-translate-file-chars (gnus-agent-method)) "/"))
  279. (defun gnus-agent-lib-file (file)
  280. "The full name of the Gnus agent library FILE."
  281. (expand-file-name file
  282. (file-name-as-directory
  283. (expand-file-name "agent.lib" (gnus-agent-directory)))))
  284. (defun gnus-agent-cat-set-property (category property value)
  285. (if value
  286. (setcdr (or (assq property category)
  287. (let ((cell (cons property nil)))
  288. (setcdr category (cons cell (cdr category)))
  289. cell)) value)
  290. (let ((category category))
  291. (while (cond ((eq property (caadr category))
  292. (setcdr category (cddr category))
  293. nil)
  294. (t
  295. (setq category (cdr category)))))))
  296. category)
  297. (eval-when-compile
  298. (defmacro gnus-agent-cat-defaccessor (name prop-name)
  299. "Define accessor and setter methods for manipulating a list of the form
  300. \(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)).
  301. Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be
  302. manipulated as follows:
  303. (func LIST): Returns VALUE1
  304. (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1."
  305. `(progn (defmacro ,name (category)
  306. (list (quote cdr) (list (quote assq)
  307. (quote (quote ,prop-name)) category)))
  308. (define-setf-method ,name (category)
  309. (let* ((--category--temp-- (make-symbol "--category--"))
  310. (--value--temp-- (make-symbol "--value--")))
  311. (list (list --category--temp--) ; temporary-variables
  312. (list category) ; value-forms
  313. (list --value--temp--) ; store-variables
  314. (let* ((category --category--temp--) ; store-form
  315. (value --value--temp--))
  316. (list (quote gnus-agent-cat-set-property)
  317. category
  318. (quote (quote ,prop-name))
  319. value))
  320. (list (quote ,name) --category--temp--) ; access-form
  321. )))))
  322. )
  323. (defmacro gnus-agent-cat-name (category)
  324. `(car ,category))
  325. (gnus-agent-cat-defaccessor
  326. gnus-agent-cat-days-until-old agent-days-until-old)
  327. (gnus-agent-cat-defaccessor
  328. gnus-agent-cat-enable-expiration agent-enable-expiration)
  329. (gnus-agent-cat-defaccessor
  330. gnus-agent-cat-groups agent-groups)
  331. (gnus-agent-cat-defaccessor
  332. gnus-agent-cat-high-score agent-high-score)
  333. (gnus-agent-cat-defaccessor
  334. gnus-agent-cat-length-when-long agent-long-article)
  335. (gnus-agent-cat-defaccessor
  336. gnus-agent-cat-length-when-short agent-short-article)
  337. (gnus-agent-cat-defaccessor
  338. gnus-agent-cat-low-score agent-low-score)
  339. (gnus-agent-cat-defaccessor
  340. gnus-agent-cat-predicate agent-predicate)
  341. (gnus-agent-cat-defaccessor
  342. gnus-agent-cat-score-file agent-score)
  343. (gnus-agent-cat-defaccessor
  344. gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces)
  345. ;; This form is equivalent to defsetf except that it calls make-symbol
  346. ;; whereas defsetf calls gensym (Using gensym creates a run-time
  347. ;; dependency on the CL library).
  348. (eval-and-compile
  349. (define-setf-method gnus-agent-cat-groups (category)
  350. (let* ((--category--temp-- (make-symbol "--category--"))
  351. (--groups--temp-- (make-symbol "--groups--")))
  352. (list (list --category--temp--)
  353. (list category)
  354. (list --groups--temp--)
  355. (let* ((category --category--temp--)
  356. (groups --groups--temp--))
  357. (list (quote gnus-agent-set-cat-groups) category groups))
  358. (list (quote gnus-agent-cat-groups) --category--temp--))))
  359. )
  360. (defun gnus-agent-set-cat-groups (category groups)
  361. (unless (eq groups 'ignore)
  362. (let ((new-g groups)
  363. (old-g (gnus-agent-cat-groups category)))
  364. (cond ((eq new-g old-g)
  365. ;; gnus-agent-add-group is fiddling with the group
  366. ;; list. Still, Im done.
  367. nil
  368. )
  369. ((eq new-g (cdr old-g))
  370. ;; gnus-agent-add-group is fiddling with the group list
  371. (setcdr (or (assq 'agent-groups category)
  372. (let ((cell (cons 'agent-groups nil)))
  373. (setcdr category (cons cell (cdr category)))
  374. cell)) new-g))
  375. (t
  376. (let ((groups groups))
  377. (while groups
  378. (let* ((group (pop groups))
  379. (old-category (gnus-group-category group)))
  380. (if (eq category old-category)
  381. nil
  382. (setf (gnus-agent-cat-groups old-category)
  383. (delete group (gnus-agent-cat-groups
  384. old-category))))))
  385. ;; Purge cache as preceding loop invalidated it.
  386. (setq gnus-category-group-cache nil))
  387. (setcdr (or (assq 'agent-groups category)
  388. (let ((cell (cons 'agent-groups nil)))
  389. (setcdr category (cons cell (cdr category)))
  390. cell)) groups))))))
  391. (defsubst gnus-agent-cat-make (name &optional default-agent-predicate)
  392. (list name `(agent-predicate . ,(or default-agent-predicate 'false))))
  393. (defun gnus-agent-read-group ()
  394. "Read a group name in the minibuffer, with completion."
  395. (let ((def (or (gnus-group-group-name) gnus-newsgroup-name)))
  396. (when def
  397. (setq def (gnus-group-decoded-name def)))
  398. (gnus-group-completing-read nil nil t nil nil def)))
  399. ;;; Fetching setup functions.
  400. (defun gnus-agent-start-fetch ()
  401. "Initialize data structures for efficient fetching."
  402. (gnus-agent-create-buffer))
  403. (defun gnus-agent-stop-fetch ()
  404. "Save all data structures and clean up."
  405. (setq gnus-agent-spam-hashtb nil)
  406. (with-current-buffer nntp-server-buffer
  407. (widen)))
  408. (defmacro gnus-agent-with-fetch (&rest forms)
  409. "Do FORMS safely."
  410. `(unwind-protect
  411. (let ((gnus-agent-fetching t))
  412. (gnus-agent-start-fetch)
  413. ,@forms)
  414. (gnus-agent-stop-fetch)))
  415. (put 'gnus-agent-with-fetch 'lisp-indent-function 0)
  416. (put 'gnus-agent-with-fetch 'edebug-form-spec '(body))
  417. (defmacro gnus-agent-append-to-list (tail value)
  418. `(setq ,tail (setcdr ,tail (cons ,value nil))))
  419. (defmacro gnus-agent-message (level &rest args)
  420. `(if (<= ,level gnus-verbose)
  421. (message ,@args)))
  422. ;;;
  423. ;;; Mode infestation
  424. ;;;
  425. (defvar gnus-agent-mode-hook nil
  426. "Hook run when installing agent mode.")
  427. (defvar gnus-agent-mode nil)
  428. (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged"))
  429. (defun gnus-agent-mode ()
  430. "Minor mode for providing a agent support in Gnus buffers."
  431. (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$"
  432. (symbol-name major-mode))
  433. (match-string 1 (symbol-name major-mode))))
  434. (mode (intern (format "gnus-agent-%s-mode" buffer))))
  435. (set (make-local-variable 'gnus-agent-mode) t)
  436. (set mode nil)
  437. (set (make-local-variable mode) t)
  438. ;; Set up the menu.
  439. (when (gnus-visual-p 'agent-menu 'menu)
  440. (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
  441. (unless (assq mode minor-mode-alist)
  442. (push (cons mode (cdr gnus-agent-mode-status)) minor-mode-alist))
  443. (unless (assq mode minor-mode-map-alist)
  444. (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
  445. buffer))))
  446. minor-mode-map-alist))
  447. (when (eq major-mode 'gnus-group-mode)
  448. (let ((init-plugged gnus-plugged)
  449. (gnus-agent-go-online nil))
  450. ;; g-a-t-p does nothing when gnus-plugged isn't changed.
  451. ;; Therefore, make certain that the current value does not
  452. ;; match the desired initial value.
  453. (setq gnus-plugged :unknown)
  454. (gnus-agent-toggle-plugged init-plugged)))
  455. (gnus-run-hooks 'gnus-agent-mode-hook
  456. (intern (format "gnus-agent-%s-mode-hook" buffer)))))
  457. (defvar gnus-agent-group-mode-map (make-sparse-keymap))
  458. (gnus-define-keys gnus-agent-group-mode-map
  459. "Ju" gnus-agent-fetch-groups
  460. "Jc" gnus-enter-category-buffer
  461. "Jj" gnus-agent-toggle-plugged
  462. "Js" gnus-agent-fetch-session
  463. "JY" gnus-agent-synchronize-flags
  464. "JS" gnus-group-send-queue
  465. "Ja" gnus-agent-add-group
  466. "Jr" gnus-agent-remove-group
  467. "Jo" gnus-agent-toggle-group-plugged)
  468. (defun gnus-agent-group-make-menu-bar ()
  469. (unless (boundp 'gnus-agent-group-menu)
  470. (easy-menu-define
  471. gnus-agent-group-menu gnus-agent-group-mode-map ""
  472. '("Agent"
  473. ["Toggle plugged" gnus-agent-toggle-plugged t]
  474. ["Toggle group plugged" gnus-agent-toggle-group-plugged t]
  475. ["List categories" gnus-enter-category-buffer t]
  476. ["Add (current) group to category" gnus-agent-add-group t]
  477. ["Remove (current) group from category" gnus-agent-remove-group t]
  478. ["Send queue" gnus-group-send-queue gnus-plugged]
  479. ("Fetch"
  480. ["All" gnus-agent-fetch-session gnus-plugged]
  481. ["Group" gnus-agent-fetch-group gnus-plugged])
  482. ["Synchronize flags" gnus-agent-synchronize-flags t]
  483. ))))
  484. (defvar gnus-agent-summary-mode-map (make-sparse-keymap))
  485. (gnus-define-keys gnus-agent-summary-mode-map
  486. "Jj" gnus-agent-toggle-plugged
  487. "Ju" gnus-agent-summary-fetch-group
  488. "JS" gnus-agent-fetch-group
  489. "Js" gnus-agent-summary-fetch-series
  490. "J#" gnus-agent-mark-article
  491. "J\M-#" gnus-agent-unmark-article
  492. "@" gnus-agent-toggle-mark
  493. "Jc" gnus-agent-catchup)
  494. (defun gnus-agent-summary-make-menu-bar ()
  495. (unless (boundp 'gnus-agent-summary-menu)
  496. (easy-menu-define
  497. gnus-agent-summary-menu gnus-agent-summary-mode-map ""
  498. '("Agent"
  499. ["Toggle plugged" gnus-agent-toggle-plugged t]
  500. ["Mark as downloadable" gnus-agent-mark-article t]
  501. ["Unmark as downloadable" gnus-agent-unmark-article t]
  502. ["Toggle mark" gnus-agent-toggle-mark t]
  503. ["Fetch downloadable" gnus-agent-summary-fetch-group t]
  504. ["Catchup undownloaded" gnus-agent-catchup t]))))
  505. (defvar gnus-agent-server-mode-map (make-sparse-keymap))
  506. (gnus-define-keys gnus-agent-server-mode-map
  507. "Jj" gnus-agent-toggle-plugged
  508. "Ja" gnus-agent-add-server
  509. "Jr" gnus-agent-remove-server)
  510. (defun gnus-agent-server-make-menu-bar ()
  511. (unless (boundp 'gnus-agent-server-menu)
  512. (easy-menu-define
  513. gnus-agent-server-menu gnus-agent-server-mode-map ""
  514. '("Agent"
  515. ["Toggle plugged" gnus-agent-toggle-plugged t]
  516. ["Add" gnus-agent-add-server t]
  517. ["Remove" gnus-agent-remove-server t]))))
  518. (defun gnus-agent-make-mode-line-string (string mouse-button mouse-func)
  519. (if (and (fboundp 'propertize)
  520. (fboundp 'make-mode-line-mouse-map))
  521. (propertize string 'local-map
  522. (make-mode-line-mouse-map mouse-button mouse-func)
  523. 'mouse-face
  524. (if (and (featurep 'xemacs)
  525. ;; XEmacs's `facep' only checks for a face
  526. ;; object, not for a face name, so it's useless
  527. ;; to check with `facep'.
  528. (find-face 'modeline))
  529. 'modeline
  530. 'mode-line-highlight))
  531. string))
  532. (defun gnus-agent-toggle-plugged (set-to)
  533. "Toggle whether Gnus is unplugged or not."
  534. (interactive (list (not gnus-plugged)))
  535. (cond ((eq set-to gnus-plugged)
  536. nil)
  537. (set-to
  538. (setq gnus-plugged set-to)
  539. (gnus-run-hooks 'gnus-agent-plugged-hook)
  540. (setcar (cdr gnus-agent-mode-status)
  541. (gnus-agent-make-mode-line-string " Plugged"
  542. 'mouse-2
  543. 'gnus-agent-toggle-plugged))
  544. (gnus-agent-go-online gnus-agent-go-online))
  545. (t
  546. (gnus-agent-close-connections)
  547. (setq gnus-plugged set-to)
  548. (gnus-run-hooks 'gnus-agent-unplugged-hook)
  549. (setcar (cdr gnus-agent-mode-status)
  550. (gnus-agent-make-mode-line-string " Unplugged"
  551. 'mouse-2
  552. 'gnus-agent-toggle-plugged))))
  553. (set-buffer-modified-p t))
  554. (defmacro gnus-agent-while-plugged (&rest body)
  555. `(let ((original-gnus-plugged gnus-plugged))
  556. (unwind-protect
  557. (progn (gnus-agent-toggle-plugged t)
  558. ,@body)
  559. (gnus-agent-toggle-plugged original-gnus-plugged))))
  560. (put 'gnus-agent-while-plugged 'lisp-indent-function 0)
  561. (put 'gnus-agent-while-plugged 'edebug-form-spec '(body))
  562. (defun gnus-agent-close-connections ()
  563. "Close all methods covered by the Gnus agent."
  564. (let ((methods (gnus-agent-covered-methods)))
  565. (while methods
  566. (gnus-close-server (pop methods)))))
  567. ;;;###autoload
  568. (defun gnus-unplugged ()
  569. "Start Gnus unplugged."
  570. (interactive)
  571. (setq gnus-plugged nil)
  572. (gnus))
  573. ;;;###autoload
  574. (defun gnus-plugged ()
  575. "Start Gnus plugged."
  576. (interactive)
  577. (setq gnus-plugged t)
  578. (gnus))
  579. ;;;###autoload
  580. (defun gnus-slave-unplugged (&optional arg)
  581. "Read news as a slave unplugged."
  582. (interactive "P")
  583. (setq gnus-plugged nil)
  584. (gnus arg nil 'slave))
  585. ;;;###autoload
  586. (defun gnus-agentize ()
  587. "Allow Gnus to be an offline newsreader.
  588. The gnus-agentize function is now called internally by gnus when
  589. gnus-agent is set. If you wish to avoid calling gnus-agentize,
  590. customize gnus-agent to nil.
  591. This will modify the `gnus-setup-news-hook', and
  592. `message-send-mail-real-function' variables, and install the Gnus agent
  593. minor mode in all Gnus buffers."
  594. (interactive)
  595. (gnus-open-agent)
  596. (unless gnus-agent-send-mail-function
  597. (setq gnus-agent-send-mail-function
  598. (or message-send-mail-real-function
  599. (function (lambda () (funcall message-send-mail-function))))
  600. message-send-mail-real-function 'gnus-agent-send-mail))
  601. ;; If the servers file doesn't exist, auto-agentize some servers and
  602. ;; save the servers file so this auto-agentizing isn't invoked
  603. ;; again.
  604. (when (and (not (file-exists-p (nnheader-concat
  605. gnus-agent-directory "lib/servers")))
  606. gnus-agent-auto-agentize-methods)
  607. (gnus-message 3 "First time agent user, agentizing remote groups...")
  608. (mapc
  609. (lambda (server-or-method)
  610. (let ((method (gnus-server-to-method server-or-method)))
  611. (when (memq (car method)
  612. gnus-agent-auto-agentize-methods)
  613. (push (gnus-method-to-server method)
  614. gnus-agent-covered-methods)
  615. (setq gnus-agent-method-p-cache nil))))
  616. (cons gnus-select-method gnus-secondary-select-methods))
  617. (gnus-agent-write-servers)))
  618. (defun gnus-agent-queue-setup (&optional group-name)
  619. "Make sure the queue group exists.
  620. Optional arg GROUP-NAME allows to specify another group."
  621. (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue"))
  622. gnus-newsrc-hashtb)
  623. (gnus-request-create-group (or group-name "queue") '(nndraft ""))
  624. (let ((gnus-level-default-subscribed 1))
  625. (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue"))
  626. nil '(nndraft "")))
  627. (gnus-group-set-parameter
  628. (format "nndraft:%s" (or group-name "queue"))
  629. 'gnus-dummy '((gnus-draft-mode)))))
  630. (defun gnus-agent-send-mail ()
  631. (if (or (not gnus-agent-queue-mail)
  632. (and gnus-plugged (not (eq gnus-agent-queue-mail 'always))))
  633. (funcall gnus-agent-send-mail-function)
  634. (goto-char (point-min))
  635. (re-search-forward
  636. (concat "^" (regexp-quote mail-header-separator) "\n"))
  637. (replace-match "\n")
  638. (gnus-agent-insert-meta-information 'mail)
  639. (gnus-request-accept-article "nndraft:queue" nil t t)
  640. (gnus-group-refresh-group "nndraft:queue")))
  641. (defun gnus-agent-insert-meta-information (type &optional method)
  642. "Insert meta-information into the message that says how it's to be posted.
  643. TYPE can be either `mail' or `news'. If the latter, then METHOD can
  644. be a select method."
  645. (save-excursion
  646. (message-remove-header gnus-agent-meta-information-header)
  647. (goto-char (point-min))
  648. (insert gnus-agent-meta-information-header ": "
  649. (symbol-name type) " " (format "%S" method)
  650. "\n")
  651. (forward-char -1)
  652. (while (search-backward "\n" nil t)
  653. (replace-match "\\n" t t))))
  654. (defun gnus-agent-restore-gcc ()
  655. "Restore GCC field from saved header."
  656. (save-excursion
  657. (goto-char (point-min))
  658. (while (re-search-forward
  659. (concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t)
  660. (replace-match "Gcc:" 'fixedcase))))
  661. (defun gnus-agent-any-covered-gcc ()
  662. (save-restriction
  663. (message-narrow-to-headers)
  664. (let* ((gcc (mail-fetch-field "gcc" nil t))
  665. (methods (and gcc
  666. (mapcar 'gnus-inews-group-method
  667. (message-unquote-tokens
  668. (message-tokenize-header
  669. gcc " ,")))))
  670. covered)
  671. (while (and (not covered) methods)
  672. (setq covered (gnus-agent-method-p (car methods))
  673. methods (cdr methods)))
  674. covered)))
  675. ;;;###autoload
  676. (defun gnus-agent-possibly-save-gcc ()
  677. "Save GCC if Gnus is unplugged."
  678. (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc))
  679. (save-excursion
  680. (goto-char (point-min))
  681. (let ((case-fold-search t))
  682. (while (re-search-forward "^gcc:" nil t)
  683. (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase))))))
  684. (defun gnus-agent-possibly-do-gcc ()
  685. "Do GCC if Gnus is plugged."
  686. (when (or gnus-plugged (not (gnus-agent-any-covered-gcc)))
  687. (gnus-inews-do-gcc)))
  688. ;;;
  689. ;;; Group mode commands
  690. ;;;
  691. (defun gnus-agent-fetch-groups (n)
  692. "Put all new articles in the current groups into the Agent."
  693. (interactive "P")
  694. (unless gnus-plugged
  695. (error "Groups can't be fetched when Gnus is unplugged"))
  696. (gnus-group-iterate n 'gnus-agent-fetch-group))
  697. (defun gnus-agent-fetch-group (&optional group)
  698. "Put all new articles in GROUP into the Agent."
  699. (interactive (list (gnus-group-group-name)))
  700. (setq group (or group gnus-newsgroup-name))
  701. (unless group
  702. (error "No group on the current line"))
  703. (if (not (gnus-agent-group-covered-p group))
  704. (message "%s isn't covered by the agent" group)
  705. (gnus-agent-while-plugged
  706. (let ((gnus-command-method (gnus-find-method-for-group group)))
  707. (gnus-agent-with-fetch
  708. (gnus-agent-fetch-group-1 group gnus-command-method)
  709. (gnus-message 5 "Fetching %s...done" group))))))
  710. (defun gnus-agent-add-group (category arg)
  711. "Add the current group to an agent category."
  712. (interactive
  713. (list
  714. (intern
  715. (gnus-completing-read
  716. "Add to category"
  717. (mapcar (lambda (cat) (symbol-name (car cat)))
  718. gnus-category-alist)
  719. t))
  720. current-prefix-arg))
  721. (let ((cat (assq category gnus-category-alist))
  722. c groups)
  723. (gnus-group-iterate arg
  724. (lambda (group)
  725. (when (gnus-agent-cat-groups (setq c (gnus-group-category group)))
  726. (setf (gnus-agent-cat-groups c)
  727. (delete group (gnus-agent-cat-groups c))))
  728. (push group groups)))
  729. (setf (gnus-agent-cat-groups cat)
  730. (nconc (gnus-agent-cat-groups cat) groups))
  731. (gnus-category-write)))
  732. (defun gnus-agent-remove-group (arg)
  733. "Remove the current group from its agent category, if any."
  734. (interactive "P")
  735. (let (c)
  736. (gnus-group-iterate arg
  737. (lambda (group)
  738. (when (gnus-agent-cat-groups (setq c (gnus-group-category group)))
  739. (setf (gnus-agent-cat-groups c)
  740. (delete group (gnus-agent-cat-groups c))))))
  741. (gnus-category-write)))
  742. (defun gnus-agent-synchronize-flags ()
  743. "Synchronize unplugged flags with servers."
  744. (interactive)
  745. (save-excursion
  746. (dolist (gnus-command-method (gnus-agent-covered-methods))
  747. (when (file-exists-p (gnus-agent-lib-file "flags"))
  748. (gnus-agent-synchronize-flags-server gnus-command-method)))))
  749. (defun gnus-agent-possibly-synchronize-flags ()
  750. "Synchronize flags according to `gnus-agent-synchronize-flags'."
  751. (interactive)
  752. (save-excursion
  753. (dolist (gnus-command-method (gnus-agent-covered-methods))
  754. (when (eq (gnus-server-status gnus-command-method) 'ok)
  755. (gnus-agent-possibly-synchronize-flags-server gnus-command-method)))))
  756. (defun gnus-agent-synchronize-flags-server (method)
  757. "Synchronize flags set when unplugged for server."
  758. (let ((gnus-command-method method)
  759. (gnus-agent nil))
  760. (when (file-exists-p (gnus-agent-lib-file "flags"))
  761. (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*"))
  762. (erase-buffer)
  763. (nnheader-insert-file-contents (gnus-agent-lib-file "flags"))
  764. (cond ((null gnus-plugged)
  765. (gnus-message
  766. 1 "You must be plugged to synchronize flags with server %s"
  767. (nth 1 gnus-command-method)))
  768. ((null (gnus-check-server gnus-command-method))
  769. (gnus-message
  770. 1 "Couldn't open server %s" (nth 1 gnus-command-method)))
  771. (t
  772. (condition-case err
  773. (while t
  774. (let ((bgn (point)))
  775. (eval (read (current-buffer)))
  776. (delete-region bgn (point))))
  777. (end-of-file
  778. (delete-file (gnus-agent-lib-file "flags")))
  779. (error
  780. (let ((file (gnus-agent-lib-file "flags")))
  781. (write-region (point-min) (point-max)
  782. (gnus-agent-lib-file "flags") nil 'silent)
  783. (error "Couldn't set flags from file %s due to %s"
  784. file (error-message-string err)))))))
  785. (kill-buffer nil))))
  786. (defun gnus-agent-possibly-synchronize-flags-server (method)
  787. "Synchronize flags for server according to `gnus-agent-synchronize-flags'."
  788. (when (and (file-exists-p (gnus-agent-lib-file "flags"))
  789. (or (and gnus-agent-synchronize-flags
  790. (not (eq gnus-agent-synchronize-flags 'ask)))
  791. (and (eq gnus-agent-synchronize-flags 'ask)
  792. (gnus-y-or-n-p
  793. (format "Synchronize flags on server `%s'? "
  794. (cadr method))))))
  795. (gnus-agent-synchronize-flags-server method)))
  796. ;;;###autoload
  797. (defun gnus-agent-rename-group (old-group new-group)
  798. "Rename fully-qualified OLD-GROUP as NEW-GROUP.
  799. Always updates the agent, even when disabled, as the old agent
  800. files would corrupt gnus when the agent was next enabled.
  801. Depends upon the caller to determine whether group renaming is
  802. supported."
  803. (let* ((old-command-method (gnus-find-method-for-group old-group))
  804. (old-path (directory-file-name
  805. (let (gnus-command-method old-command-method)
  806. (gnus-agent-group-pathname old-group))))
  807. (new-command-method (gnus-find-method-for-group new-group))
  808. (new-path (directory-file-name
  809. (let (gnus-command-method new-command-method)
  810. (gnus-agent-group-pathname new-group))))
  811. (file-name-coding-system nnmail-pathname-coding-system))
  812. (gnus-rename-file old-path new-path t)
  813. (let* ((old-real-group (gnus-group-real-name old-group))
  814. (new-real-group (gnus-group-real-name new-group))
  815. (old-active (gnus-agent-get-group-info old-command-method old-real-group)))
  816. (gnus-agent-save-group-info old-command-method old-real-group nil)
  817. (gnus-agent-save-group-info new-command-method new-real-group old-active)
  818. (let ((old-local (gnus-agent-get-local old-group
  819. old-real-group old-command-method)))
  820. (gnus-agent-set-local old-group
  821. nil nil
  822. old-real-group old-command-method)
  823. (gnus-agent-set-local new-group
  824. (car old-local) (cdr old-local)
  825. new-real-group new-command-method)))))
  826. ;;;###autoload
  827. (defun gnus-agent-delete-group (group)
  828. "Delete fully-qualified GROUP.
  829. Always updates the agent, even when disabled, as the old agent
  830. files would corrupt gnus when the agent was next enabled.
  831. Depends upon the caller to determine whether group deletion is
  832. supported."
  833. (let* ((command-method (gnus-find-method-for-group group))
  834. (path (directory-file-name
  835. (let (gnus-command-method command-method)
  836. (gnus-agent-group-pathname group))))
  837. (file-name-coding-system nnmail-pathname-coding-system))
  838. (gnus-delete-directory path)
  839. (let* ((real-group (gnus-group-real-name group)))
  840. (gnus-agent-save-group-info command-method real-group nil)
  841. (let ((local (gnus-agent-get-local group
  842. real-group command-method)))
  843. (gnus-agent-set-local group
  844. nil nil
  845. real-group command-method)))))
  846. ;;;
  847. ;;; Server mode commands
  848. ;;;
  849. (defun gnus-agent-add-server ()
  850. "Enroll SERVER in the agent program."
  851. (interactive)
  852. (let* ((server (gnus-server-server-name))
  853. (named-server (gnus-server-named-server))
  854. (method (and server
  855. (gnus-server-get-method nil server))))
  856. (unless server
  857. (error "No server on the current line"))
  858. (when (gnus-agent-method-p method)
  859. (error "Server already in the agent program"))
  860. (push named-server gnus-agent-covered-methods)
  861. (setq gnus-agent-method-p-cache nil)
  862. (gnus-server-update-server server)
  863. (gnus-agent-write-servers)
  864. (gnus-message 1 "Entered %s into the Agent" server)))
  865. (defun gnus-agent-remove-server ()
  866. "Remove SERVER from the agent program."
  867. (interactive)
  868. (let* ((server (gnus-server-server-name))
  869. (named-server (gnus-server-named-server)))
  870. (unless server
  871. (error "No server on the current line"))
  872. (unless (member named-server gnus-agent-covered-methods)
  873. (error "Server not in the agent program"))
  874. (setq gnus-agent-covered-methods
  875. (delete named-server gnus-agent-covered-methods)
  876. gnus-agent-method-p-cache nil)
  877. (gnus-server-update-server server)
  878. (gnus-agent-write-servers)
  879. (gnus-message 1 "Removed %s from the agent" server)))
  880. (defun gnus-agent-read-servers ()
  881. "Read the alist of covered servers."
  882. (setq gnus-agent-covered-methods
  883. (gnus-agent-read-file
  884. (nnheader-concat gnus-agent-directory "lib/servers"))
  885. gnus-agent-method-p-cache nil)
  886. ;; I am called so early in start-up that I can not validate server
  887. ;; names. When that is the case, I skip the validation. That is
  888. ;; alright as the gnus startup code calls the validate methods
  889. ;; directly.
  890. (if gnus-server-alist
  891. (gnus-agent-read-servers-validate)))
  892. (defun gnus-agent-read-servers-validate ()
  893. (mapcar (lambda (server-or-method)
  894. (let* ((server (if (stringp server-or-method)
  895. server-or-method
  896. (gnus-method-to-server server-or-method)))
  897. (method (gnus-server-to-method server)))
  898. (if method
  899. (unless (member server gnus-agent-covered-methods)
  900. (push server gnus-agent-covered-methods)
  901. (setq gnus-agent-method-p-cache nil))
  902. (gnus-message 8 "Ignoring disappeared server `%s'" server))))
  903. (prog1 gnus-agent-covered-methods
  904. (setq gnus-agent-covered-methods nil))))
  905. (defun gnus-agent-read-servers-validate-native (native-method)
  906. (setq gnus-agent-covered-methods
  907. (mapcar (lambda (method)
  908. (if (or (not method)
  909. (equal method native-method))
  910. "native"
  911. method)) gnus-agent-covered-methods)))
  912. (defun gnus-agent-write-servers ()
  913. "Write the alist of covered servers."
  914. (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
  915. (let ((coding-system-for-write nnheader-file-coding-system)
  916. (file-name-coding-system nnmail-pathname-coding-system))
  917. (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers")
  918. (prin1 gnus-agent-covered-methods
  919. (current-buffer)))))
  920. ;;;
  921. ;;; Summary commands
  922. ;;;
  923. (defun gnus-agent-mark-article (n &optional unmark)
  924. "Mark the next N articles as downloadable.
  925. If N is negative, mark backward instead. If UNMARK is non-nil, remove
  926. the mark instead. The difference between N and the actual number of
  927. articles marked is returned."
  928. (interactive "p")
  929. (let ((backward (< n 0))
  930. (n (abs n)))
  931. (while (and
  932. (> n 0)
  933. (progn
  934. (gnus-summary-set-agent-mark
  935. (gnus-summary-article-number) unmark)
  936. (zerop (gnus-summary-next-subject (if backward -1 1) nil t))))
  937. (setq n (1- n)))
  938. (when (/= 0 n)
  939. (gnus-message 7 "No more articles"))
  940. (gnus-summary-recenter)
  941. (gnus-summary-position-point)
  942. n))
  943. (defun gnus-agent-unmark-article (n)
  944. "Remove the downloadable mark from the next N articles.
  945. If N is negative, unmark backward instead. The difference between N and
  946. the actual number of articles unmarked is returned."
  947. (interactive "p")
  948. (gnus-agent-mark-article n t))
  949. (defun gnus-agent-toggle-mark (n)
  950. "Toggle the downloadable mark from the next N articles.
  951. If N is negative, toggle backward instead. The difference between N and
  952. the actual number of articles toggled is returned."
  953. (interactive "p")
  954. (gnus-agent-mark-article n 'toggle))
  955. (defun gnus-summary-set-agent-mark (article &optional unmark)
  956. "Mark ARTICLE as downloadable. If UNMARK is nil, article is marked.
  957. When UNMARK is t, the article is unmarked. For any other value, the
  958. article's mark is toggled."
  959. (let ((unmark (cond ((eq nil unmark)
  960. nil)
  961. ((eq t unmark)
  962. t)
  963. (t
  964. (memq article gnus-newsgroup-downloadable)))))
  965. (when (gnus-summary-goto-subject article nil t)
  966. (gnus-summary-update-mark
  967. (if unmark
  968. (progn
  969. (setq gnus-newsgroup-downloadable
  970. (delq article gnus-newsgroup-downloadable))
  971. (gnus-article-mark article))
  972. (setq gnus-newsgroup-downloadable
  973. (gnus-add-to-sorted-list gnus-newsgroup-downloadable article))
  974. gnus-downloadable-mark)
  975. 'unread))))
  976. ;;;###autoload
  977. (defun gnus-agent-get-undownloaded-list ()
  978. "Construct list of articles that have not been downloaded."
  979. (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
  980. (when (set (make-local-variable 'gnus-newsgroup-agentized)
  981. (gnus-agent-method-p gnus-command-method))
  982. (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name))
  983. (headers (sort (mapcar (lambda (h)
  984. (mail-header-number h))
  985. gnus-newsgroup-headers) '<))
  986. (cached (and gnus-use-cache gnus-newsgroup-cached))
  987. (undownloaded (list nil))
  988. (tail-undownloaded undownloaded)
  989. (unfetched (list nil))
  990. (tail-unfetched unfetched))
  991. (while (and alist headers)
  992. (let ((a (caar alist))
  993. (h (car headers)))
  994. (cond ((< a h)
  995. ;; Ignore IDs in the alist that are not being
  996. ;; displayed in the summary.
  997. (setq alist (cdr alist)))
  998. ((> a h)
  999. ;; Headers that are not in the alist should be
  1000. ;; fictitious (see nnagent-retrieve-headers); they
  1001. ;; imply that this article isn't in the agent.
  1002. (gnus-agent-append-to-list tail-undownloaded h)
  1003. (gnus-agent-append-to-list tail-unfetched h)
  1004. (setq headers (cdr headers)))
  1005. ((cdar alist)
  1006. (setq alist (cdr alist))
  1007. (setq headers (cdr headers))
  1008. nil ; ignore already downloaded
  1009. )
  1010. (t
  1011. (setq alist (cdr alist))
  1012. (setq headers (cdr headers))
  1013. ;; This article isn't in the agent. Check to see
  1014. ;; if it is in the cache. If it is, it's been
  1015. ;; downloaded.
  1016. (while (and cached (< (car cached) a))
  1017. (setq cached (cdr cached)))
  1018. (unless (equal a (car cached))
  1019. (gnus-agent-append-to-list tail-undownloaded a))))))
  1020. (while headers
  1021. (let ((num (pop headers)))
  1022. (gnus-agent-append-to-list tail-undownloaded num)
  1023. (gnus-agent-append-to-list tail-unfetched num)))
  1024. (setq gnus-newsgroup-undownloaded (cdr undownloaded)
  1025. gnus-newsgroup-unfetched (cdr unfetched))))))
  1026. (defun gnus-agent-catchup ()
  1027. "Mark as read all unhandled articles.
  1028. An article is unhandled if it is neither cached, nor downloaded, nor
  1029. downloadable."
  1030. (interactive)
  1031. (save-excursion
  1032. (let ((articles gnus-newsgroup-undownloaded))
  1033. (when (or gnus-newsgroup-downloadable
  1034. gnus-newsgroup-cached)
  1035. (setq articles (gnus-sorted-ndifference
  1036. (gnus-sorted-ndifference
  1037. (gnus-copy-sequence articles)
  1038. gnus-newsgroup-downloadable)
  1039. gnus-newsgroup-cached)))
  1040. (while articles
  1041. (gnus-summary-mark-article
  1042. (pop articles) gnus-catchup-mark)))
  1043. (gnus-summary-position-point)))
  1044. (defun gnus-agent-summary-fetch-series ()
  1045. "Fetch the process-marked articles into the Agent."
  1046. (interactive)
  1047. (when gnus-newsgroup-processable
  1048. (setq gnus-newsgroup-downloadable
  1049. (let* ((dl gnus-newsgroup-downloadable)
  1050. (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<))
  1051. (gnus-newsgroup-downloadable processable))
  1052. (gnus-agent-summary-fetch-group)
  1053. ;; For each article that I processed that is no longer
  1054. ;; undownloaded, remove its processable mark.
  1055. (mapc #'gnus-summary-remove-process-mark
  1056. (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded))
  1057. ;; The preceding call to (gnus-agent-summary-fetch-group)
  1058. ;; updated the temporary gnus-newsgroup-downloadable to
  1059. ;; remove each article successfully fetched. Now, I
  1060. ;; update the real gnus-newsgroup-downloadable to only
  1061. ;; include undownloaded articles.
  1062. (gnus-sorted-ndifference dl (gnus-sorted-ndifference processable gnus-newsgroup-undownloaded))))))
  1063. (defun gnus-agent-summary-fetch-group (&optional all)
  1064. "Fetch the downloadable articles in the group.
  1065. Optional arg ALL, if non-nil, means to fetch all articles."
  1066. (interactive "P")
  1067. (let ((articles
  1068. (if all gnus-newsgroup-articles
  1069. gnus-newsgroup-downloadable))
  1070. (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))
  1071. fetched-articles)
  1072. (gnus-agent-while-plugged
  1073. (unless articles
  1074. (error "No articles to download"))
  1075. (gnus-agent-with-fetch
  1076. (setq gnus-newsgroup-undownloaded
  1077. (gnus-sorted-ndifference
  1078. gnus-newsgroup-undownloaded
  1079. (setq fetched-articles
  1080. (gnus-agent-fetch-articles
  1081. gnus-newsgroup-name articles)))))
  1082. (save-excursion
  1083. (dolist (article articles)
  1084. (let ((was-marked-downloadable
  1085. (memq article gnus-newsgroup-downloadable)))
  1086. (cond (gnus-agent-mark-unread-after-downloaded
  1087. (setq gnus-newsgroup-downloadable
  1088. (delq article gnus-newsgroup-downloadable))
  1089. (when (and (not (member article gnus-newsgroup-dormant))
  1090. (not (member article gnus-newsgroup-marked)))
  1091. (gnus-summary-mark-article article gnus-unread-mark)))
  1092. (was-marked-downloadable
  1093. (gnus-summary-set-agent-mark article t)))
  1094. (when (gnus-summary-goto-subject article nil t)
  1095. (gnus-summary-update-download-mark article))))))
  1096. fetched-articles))
  1097. (defun gnus-agent-fetch-selected-article ()
  1098. "Fetch the current article as it is selected.
  1099. This can be added to `gnus-select-article-hook' or
  1100. `gnus-mark-article-hook'."
  1101. (let ((gnus-command-method gnus-current-select-method))
  1102. (when (and gnus-plugged (gnus-agent-method-p gnus-command-method))
  1103. (when (gnus-agent-fetch-articles
  1104. gnus-newsgroup-name
  1105. (list gnus-current-article))
  1106. (setq gnus-newsgroup-undownloaded
  1107. (delq gnus-current-article gnus-newsgroup-undownloaded))
  1108. (gnus-summary-update-download-mark gnus-current-article)))))
  1109. ;;;
  1110. ;;; Internal functions
  1111. ;;;
  1112. (defun gnus-agent-synchronize-group-flags (group actions server)
  1113. "Update a plugged group by performing the indicated actions."
  1114. (let* ((gnus-command-method (gnus-server-to-method server))
  1115. (info
  1116. ;; This initializer is required as gnus-request-set-mark
  1117. ;; calls gnus-group-real-name to strip off the host name
  1118. ;; before calling the backend. Now that the backend is
  1119. ;; trying to call gnus-request-set-mark, I have to
  1120. ;; reconstruct the original group name.
  1121. (or (gnus-get-info group)
  1122. (gnus-get-info
  1123. (setq group (gnus-group-full-name
  1124. group gnus-command-method))))))
  1125. (gnus-request-set-mark group actions)
  1126. (when info
  1127. (dolist (action actions)
  1128. (let ((range (nth 0 action))
  1129. (what (nth 1 action))
  1130. (marks (nth 2 action)))
  1131. (dolist (mark marks)
  1132. (cond ((eq mark 'read)
  1133. (gnus-info-set-read
  1134. info
  1135. (funcall (if (eq what 'add)
  1136. 'gnus-range-add
  1137. 'gnus-remove-from-range)
  1138. (gnus-info-read info)
  1139. range))
  1140. (gnus-get-unread-articles-in-group
  1141. info
  1142. (gnus-active (gnus-info-group info))))
  1143. ((memq mark '(tick))
  1144. (let ((info-marks (assoc mark (gnus-info-marks info))))
  1145. (unless info-marks
  1146. (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info))))
  1147. (setcdr info-marks (funcall (if (eq what 'add)
  1148. 'gnus-range-add
  1149. 'gnus-remove-from-range)
  1150. (cdr info-marks)
  1151. range))))))))
  1152. ;;Marks can be synchronized at any time by simply toggling from
  1153. ;;unplugged to plugged. If that is what is happening right now, make
  1154. ;;sure that the group buffer is up to date.
  1155. (when (gnus-buffer-live-p gnus-group-buffer)
  1156. (gnus-group-update-group group t)))
  1157. nil))
  1158. (defun gnus-agent-save-active (method)
  1159. (when (gnus-agent-method-p method)
  1160. (let* ((gnus-command-method method)
  1161. (new (gnus-make-hashtable (count-lines (point-min) (point-max))))
  1162. (file (gnus-agent-lib-file "active")))
  1163. (gnus-active-to-gnus-format nil new)
  1164. (gnus-agent-write-active file new)
  1165. (erase-buffer)
  1166. (let ((nnheader-file-coding-system gnus-agent-file-coding-system))
  1167. (nnheader-insert-file-contents file)))))
  1168. (defun gnus-agent-write-active (file new)
  1169. (gnus-make-directory (file-name-directory file))
  1170. (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system))
  1171. ;; The hashtable contains real names of groups. However, do NOT
  1172. ;; add the foreign server prefix as gnus-active-to-gnus-format
  1173. ;; will add it while reading the file.
  1174. (gnus-write-active-file file new nil)))
  1175. ;;;###autoload
  1176. (defun gnus-agent-possibly-alter-active (group active &optional info)
  1177. "Possibly expand a group's active range to include articles
  1178. downloaded into the agent."
  1179. (let* ((gnus-command-method (or gnus-command-method
  1180. (gnus-find-method-for-group group))))
  1181. (when (gnus-agent-method-p gnus-command-method)
  1182. (let* ((local (gnus-agent-get-local group))
  1183. (active-min (or (car active) 0))
  1184. (active-max (or (cdr active) 0))
  1185. (agent-min (or (car local) active-min))
  1186. (agent-max (or (cdr local) active-max)))
  1187. (when (< agent-min active-min)
  1188. (setcar active agent-min))
  1189. (when (> agent-max active-max)
  1190. (setcdr active agent-max))
  1191. (when (and info (< agent-max (- active-min 100)))
  1192. ;; I'm expanding the active range by such a large amount
  1193. ;; that there is a gap of more than 100 articles between the
  1194. ;; last article known to the agent and the first article
  1195. ;; currently available on the server. This gap contains
  1196. ;; articles that have been lost, mark them as read so that
  1197. ;; gnus doesn't waste resources trying to fetch them.
  1198. ;; NOTE: I don't do this for smaller gaps (< 100) as I don't
  1199. ;; want to modify the local file everytime someone restarts
  1200. ;; gnus. The small gap will cause a tiny performance hit
  1201. ;; when gnus tries, and fails, to retrieve the articles.
  1202. ;; Still that should be smaller than opening a buffer,
  1203. ;; printing this list to the buffer, and then writing it to a
  1204. ;; file.
  1205. (let ((read (gnus-info-read info)))
  1206. (gnus-info-set-read
  1207. info
  1208. (gnus-range-add
  1209. read
  1210. (list (cons (1+ agent-max)
  1211. (1- active-min))))))
  1212. ;; Lie about the agent's local range for this group to
  1213. ;; disable the set read each time this server is opened.
  1214. ;; NOTE: Opening this group will restore the valid local
  1215. ;; range but it will also expand the local range to
  1216. ;; encompass the new active range.
  1217. (gnus-agent-set-local group agent-min (1- active-min)))))))
  1218. (defun gnus-agent-save-group-info (method group active)
  1219. "Update a single group's active range in the agent's copy of the server's active file."
  1220. (when (gnus-agent-method-p method)
  1221. (let* ((gnus-command-method (or method gnus-command-method))
  1222. (coding-system-for-write nnheader-file-coding-system)
  1223. (file-name-coding-system nnmail-pathname-coding-system)
  1224. (file (gnus-agent-lib-file "active"))
  1225. oactive-min oactive-max)
  1226. (gnus-make-directory (file-name-directory file))
  1227. (with-temp-file file
  1228. ;; Emacs got problem to match non-ASCII group in multibyte buffer.
  1229. (mm-disable-multibyte)
  1230. (when (file-exists-p file)
  1231. (nnheader-insert-file-contents file)
  1232. (goto-char (point-min))
  1233. (when (re-search-forward
  1234. (concat "^" (regexp-quote group) " ") nil t)
  1235. (save-excursion
  1236. (setq oactive-max (read (current-buffer)) ;; max
  1237. oactive-min (read (current-buffer)))) ;; min
  1238. (gnus-delete-line)))
  1239. (when active
  1240. (insert (format "%S %d %d y\n" (intern group)
  1241. (max (or oactive-max (cdr active)) (cdr active))
  1242. (min (or oactive-min (car active)) (car active))))
  1243. (goto-char (point-max))
  1244. (while (search-backward "\\." nil t)
  1245. (delete-char 1)))))))
  1246. (defun gnus-agent-get-group-info (method group)
  1247. "Get a single group's active range in the agent's copy of the server's active file."
  1248. (when (gnus-agent-method-p method)
  1249. (let* ((gnus-command-method (or method gnus-command-method))
  1250. (coding-system-for-write nnheader-file-coding-system)
  1251. (file-name-coding-system nnmail-pathname-coding-system)
  1252. (file (gnus-agent-lib-file "active"))
  1253. oactive-min oactive-max)
  1254. (gnus-make-directory (file-name-directory file))
  1255. (with-temp-buffer
  1256. ;; Emacs got problem to match non-ASCII group in multibyte buffer.
  1257. (mm-disable-multibyte)
  1258. (when (file-exists-p file)
  1259. (nnheader-insert-file-contents file)
  1260. (goto-char (point-min))
  1261. (when (re-search-forward
  1262. (concat "^" (regexp-quote group) " ") nil t)
  1263. (save-excursion
  1264. (setq oactive-max (read (current-buffer)) ;; max
  1265. oactive-min (read (current-buffer))) ;; min
  1266. (cons oactive-min oactive-max))))))))
  1267. (defvar gnus-agent-decoded-group-names nil
  1268. "Alist of non-ASCII group names and decoded ones.")
  1269. (defun gnus-agent-decoded-group-name (group)
  1270. "Return a decoded group name of GROUP."
  1271. (or (cdr (assoc group gnus-agent-decoded-group-names))
  1272. (if (string-match "[^\000-\177]" group)
  1273. (let ((decoded (gnus-group-decoded-name group)))
  1274. (push (cons group decoded) gnus-agent-decoded-group-names)
  1275. decoded)
  1276. group)))
  1277. (defun gnus-agent-group-path (group)
  1278. "Translate GROUP into a file name."
  1279. ;; NOTE: This is what nnmail-group-pathname does as of Apr 2003.
  1280. ;; The two methods must be kept synchronized, which is why
  1281. ;; gnus-agent-group-pathname was added.
  1282. (setq group
  1283. (nnheader-translate-file-chars
  1284. (nnheader-replace-duplicate-chars-in-string
  1285. (nnheader-replace-chars-in-string
  1286. (gnus-group-real-name (gnus-agent-decoded-group-name group))
  1287. ?/ ?_)
  1288. ?. ?_)))
  1289. (if (or nnmail-use-long-file-names
  1290. (file-directory-p (expand-file-name group (gnus-agent-directory))))
  1291. group
  1292. (nnheader-replace-chars-in-string group ?. ?/)))
  1293. (defun gnus-agent-group-pathname (group)
  1294. "Translate GROUP into a file name."
  1295. ;; nnagent uses nnmail-group-pathname to read articles while
  1296. ;; unplugged. The agent must, therefore, use the same directory
  1297. ;; while plugged.
  1298. (nnmail-group-pathname
  1299. (gnus-group-real-name (gnus-agent-decoded-group-name group))
  1300. (if gnus-command-method
  1301. (gnus-agent-directory)
  1302. (let ((gnus-command-method (gnus-find-method-for-group group)))
  1303. (gnus-agent-directory)))))
  1304. (defun gnus-agent-get-function (method)
  1305. (if (gnus-online method)
  1306. (car method)
  1307. (require 'nnagent)
  1308. 'nnagent))
  1309. (defun gnus-agent-covered-methods ()
  1310. "Return the subset of methods that are covered by the agent."
  1311. (delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods)))
  1312. ;;; History functions
  1313. (defun gnus-agent-history-buffer ()
  1314. (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers)))
  1315. (defun gnus-agent-open-history ()
  1316. (save-excursion
  1317. (push (cons (gnus-agent-method)
  1318. (set-buffer (gnus-get-buffer-create
  1319. (format " *Gnus agent %s history*"
  1320. (gnus-agent-method)))))
  1321. gnus-agent-history-buffers)
  1322. (mm-disable-multibyte) ;; everything is binary
  1323. (erase-buffer)
  1324. (insert "\n")
  1325. (let ((file (gnus-agent-lib-file "history")))
  1326. (when (file-exists-p file)
  1327. (nnheader-insert-file-contents file))
  1328. (set (make-local-variable 'gnus-agent-file-name) file))))
  1329. (defun gnus-agent-close-history ()
  1330. (when (gnus-buffer-live-p gnus-agent-current-history)
  1331. (kill-buffer gnus-agent-current-history)
  1332. (setq gnus-agent-history-buffers
  1333. (delq (assoc (gnus-agent-method) gnus-agent-history-buffers)
  1334. gnus-agent-history-buffers))))
  1335. ;;;
  1336. ;;; Fetching
  1337. ;;;
  1338. (defun gnus-agent-fetch-articles (group articles)
  1339. "Fetch ARTICLES from GROUP and put them into the Agent."
  1340. (when articles
  1341. (gnus-agent-load-alist group)
  1342. (let* ((alist gnus-agent-article-alist)
  1343. (headers (if (< (length articles) 2) nil gnus-newsgroup-headers))
  1344. (selected-sets (list nil))
  1345. (current-set-size 0)
  1346. article
  1347. header-number)
  1348. ;; Check each article
  1349. (while (setq article (pop articles))
  1350. ;; Skip alist entries preceding this article
  1351. (while (> article (or (caar alist) (1+ article)))
  1352. (setq alist (cdr alist)))
  1353. ;; Prune off articles that we have already fetched.
  1354. (unless (and (eq article (caar alist))
  1355. (cdar alist))
  1356. ;; Skip headers preceding this article
  1357. (while (> article
  1358. (setq header-number
  1359. (let* ((header (car headers)))
  1360. (if header
  1361. (mail-header-number header)
  1362. (1+ article)))))
  1363. (setq headers (cdr headers)))
  1364. ;; Add this article to the current set
  1365. (setcar selected-sets (cons article (car selected-sets)))
  1366. ;; Update the set size, when the set is too large start a
  1367. ;; new one. I do this after adding the article as I want at
  1368. ;; least one article in each set.
  1369. (when (< gnus-agent-max-fetch-size
  1370. (setq current-set-size
  1371. (+ current-set-size
  1372. (if (= header-number article)
  1373. (let ((char-size (mail-header-chars
  1374. (car headers))))
  1375. (if (<= char-size 0)
  1376. ;; The char size was missing/invalid,
  1377. ;; assume a worst-case situation of
  1378. ;; 65 char/line. If the line count
  1379. ;; is missing, arbitrarily assume a
  1380. ;; size of 1000 characters.
  1381. (max (* 65 (mail-header-lines
  1382. (car headers)))
  1383. 1000)
  1384. char-size))
  1385. 0))))
  1386. (setcar selected-sets (nreverse (car selected-sets)))
  1387. (setq selected-sets (cons nil selected-sets)
  1388. current-set-size 0))))
  1389. (when (or (cdr selected-sets) (car selected-sets))
  1390. (let* ((fetched-articles (list nil))
  1391. (tail-fetched-articles fetched-articles)
  1392. (dir (gnus-agent-group-pathname group))
  1393. (date (time-to-days (current-time)))
  1394. (case-fold-search t)
  1395. pos crosses id
  1396. (file-name-coding-system nnmail-pathname-coding-system))
  1397. (setcar selected-sets (nreverse (car selected-sets)))
  1398. (setq selected-sets (nreverse selected-sets))
  1399. (gnus-make-directory dir)
  1400. (gnus-message 7 "Fetching articles for %s..."
  1401. (gnus-agent-decoded-group-name group))
  1402. (unwind-protect
  1403. (while (setq articles (pop selected-sets))
  1404. ;; Fetch the articles from the backend.
  1405. (if (gnus-check-backend-function 'retrieve-articles group)
  1406. (setq pos (gnus-retrieve-articles articles group))
  1407. (with-temp-buffer
  1408. (let (article)
  1409. (while (setq article (pop articles))
  1410. (gnus-message 10 "Fetching article %s for %s..."
  1411. article
  1412. (gnus-agent-decoded-group-name group))
  1413. (when (or
  1414. (gnus-backlog-request-article group article
  1415. nntp-server-buffer)
  1416. (gnus-request-article article group))
  1417. (goto-char (point-max))
  1418. (push (cons article (point)) pos)
  1419. (insert-buffer-substring nntp-server-buffer)))
  1420. (copy-to-buffer
  1421. nntp-server-buffer (point-min) (point-max))
  1422. (setq pos (nreverse pos)))))
  1423. ;; Then save these articles into the Agent.
  1424. (with-current-buffer nntp-server-buffer
  1425. (while pos
  1426. (narrow-to-region (cdar pos) (or (cdadr pos) (point-max)))
  1427. (goto-char (point-min))
  1428. (unless (eobp) ;; Don't save empty articles.
  1429. (when (search-forward "\n\n" nil t)
  1430. (when (search-backward "\nXrefs: " nil t)
  1431. ;; Handle cross posting.
  1432. (goto-char (match-end 0)) ; move to end of header name
  1433. (skip-chars-forward "^ ") ; skip server name
  1434. (skip-chars-forward " ")
  1435. (setq crosses nil)
  1436. (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *")
  1437. (push (cons (buffer-substring (match-beginning 1)
  1438. (match-end 1))
  1439. (string-to-number
  1440. (buffer-substring (match-beginning 2)
  1441. (match-end 2))))
  1442. crosses)
  1443. (goto-char (match-end 0)))
  1444. (gnus-agent-crosspost crosses (caar pos) date)))
  1445. (goto-char (point-min))
  1446. (if (not (re-search-forward
  1447. "^Message-ID: *<\\([^>\n]+\\)>" nil t))
  1448. (setq id "No-Message-ID-in-article")
  1449. (setq id (buffer-substring
  1450. (match-beginning 1) (match-end 1))))
  1451. (let ((coding-system-for-write
  1452. gnus-agent-file-coding-system))
  1453. (write-region (point-min) (point-max)
  1454. (concat dir (number-to-string (caar pos)))
  1455. nil 'silent))
  1456. (gnus-agent-append-to-list
  1457. tail-fetched-articles (caar pos)))
  1458. (widen)
  1459. (setq pos (cdr pos)))))
  1460. (gnus-agent-save-alist group (cdr fetched-articles) date)
  1461. (gnus-agent-update-files-total-fetched-for group (cdr fetched-articles))
  1462. (gnus-message 7 ""))
  1463. (cdr fetched-articles))))))
  1464. (defun gnus-agent-unfetch-articles (group articles)
  1465. "Delete ARTICLES that were fetched from GROUP into the agent."
  1466. (when articles
  1467. (gnus-agent-with-refreshed-group
  1468. group
  1469. (gnus-agent-load-alist group)
  1470. (let* ((alist (cons nil gnus-agent-article-alist))
  1471. (articles (sort articles #'<))
  1472. (next-possibility alist)
  1473. (delete-this (pop articles)))
  1474. (while (and (cdr next-possibility) delete-this)
  1475. (let ((have-this (caar (cdr next-possibility))))
  1476. (cond
  1477. ((< delete-this have-this)
  1478. (setq delete-this (pop articles)))
  1479. ((= delete-this have-this)
  1480. (let ((timestamp (cdar (cdr next-possibility))))
  1481. (when timestamp
  1482. (let* ((file-name (concat (gnus-agent-group-pathname group)
  1483. (number-to-string have-this)))
  1484. (size-file
  1485. (float (or (and gnus-agent-total-fetched-hashtb
  1486. (nth 7 (file-attributes file-name)))
  1487. 0)))
  1488. (file-name-coding-system
  1489. nnmail-pathname-coding-system))
  1490. (delete-file file-name)
  1491. (gnus-agent-update-files-total-fetched-for
  1492. group (- size-file)))))
  1493. (setcdr next-possibility (cddr next-possibility)))
  1494. (t
  1495. (setq next-possibility (cdr next-possibility))))))
  1496. (setq gnus-agent-article-alist (cdr alist))
  1497. (gnus-agent-save-alist group)))))
  1498. (defun gnus-agent-crosspost (crosses article &optional date)
  1499. (setq date (or date t))
  1500. (let (gnus-agent-article-alist group alist beg end)
  1501. (with-current-buffer gnus-agent-overview-buffer
  1502. (when (nnheader-find-nov-line article)
  1503. (forward-word 1)
  1504. (setq beg (point))
  1505. (setq end (progn (forward-line 1) (point)))))
  1506. (while crosses
  1507. (setq group (caar crosses))
  1508. (unless (setq alist (assoc group gnus-agent-group-alist))
  1509. (push (setq alist (list group (gnus-agent-load-alist (caar crosses))))
  1510. gnus-agent-group-alist))
  1511. (setcdr alist (cons (cons (cdar crosses) date) (cdr alist)))
  1512. (with-current-buffer (gnus-get-buffer-create
  1513. (format " *Gnus agent overview %s*"group))
  1514. (when (= (point-max) (point-min))
  1515. (push (cons group (current-buffer)) gnus-agent-buffer-alist)
  1516. (ignore-errors
  1517. (let ((file-name-coding-system nnmail-pathname-coding-system))
  1518. (nnheader-insert-file-contents
  1519. (gnus-agent-article-name ".overview" group)))))
  1520. (nnheader-find-nov-line (string-to-number (cdar crosses)))
  1521. (insert (string-to-number (cdar crosses)))
  1522. (insert-buffer-substring gnus-agent-overview-buffer beg end)
  1523. (gnus-agent-check-overview-buffer))
  1524. (setq crosses (cdr crosses)))))
  1525. (defun gnus-agent-backup-overview-buffer ()
  1526. (when gnus-newsgroup-name
  1527. (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name))
  1528. (cnt 0)
  1529. name
  1530. (file-name-coding-system nnmail-pathname-coding-system))
  1531. (while (file-exists-p
  1532. (setq name (concat root "~"
  1533. (int-to-string (setq cnt (1+ cnt))) "~"))))
  1534. (write-region (point-min) (point-max) name nil 'no-msg)
  1535. (gnus-message 1 "Created backup copy of overview in %s." name)))
  1536. t)
  1537. (defun gnus-agent-check-overview-buffer (&optional buffer)
  1538. "Check the overview file given for sanity.
  1539. In particular, checks that the file is sorted by article number
  1540. and that there are no duplicates."
  1541. (let ((prev-num -1)
  1542. (backed-up nil))
  1543. (save-excursion
  1544. (when buffer
  1545. (set-buffer buffer))
  1546. (save-restriction
  1547. (widen)
  1548. (goto-char (point-min))
  1549. (while (< (point) (point-max))
  1550. (let ((p (point))
  1551. (cur (condition-case nil
  1552. (read (current-buffer))
  1553. (error nil))))
  1554. (cond
  1555. ((or (not (integerp cur))
  1556. (not (eq (char-after) ?\t)))
  1557. (or backed-up
  1558. (setq backed-up (gnus-agent-backup-overview-buffer)))
  1559. (gnus-message 1
  1560. "Overview buffer contains garbage '%s'."
  1561. (buffer-substring
  1562. p (point-at-eol))))
  1563. ((= cur prev-num)
  1564. (or backed-up
  1565. (setq backed-up (gnus-agent-backup-overview-buffer)))
  1566. (gnus-message 1
  1567. "Duplicate overview line for %d" cur)
  1568. (delete-region p (progn (forward-line 1) (point))))
  1569. ((< cur prev-num)
  1570. (or backed-up
  1571. (setq backed-up (gnus-agent-backup-overview-buffer)))
  1572. (gnus-message 1 "Overview buffer not sorted!")
  1573. (sort-numeric-fields 1 (point-min) (point-max))
  1574. (goto-char (point-min))
  1575. (setq prev-num -1))
  1576. (t
  1577. (setq prev-num cur)))
  1578. (forward-line 1)))))))
  1579. (defun gnus-agent-flush-server (&optional server-or-method)
  1580. "Flush all agent index files for every subscribed group within
  1581. the given SERVER-OR-METHOD. When called with nil, the current
  1582. value of gnus-command-method identifies the server."
  1583. (let* ((gnus-command-method (if server-or-method
  1584. (gnus-server-to-method server-or-method)
  1585. gnus-command-method))
  1586. (alist gnus-newsrc-alist))
  1587. (while alist
  1588. (let ((entry (pop alist)))
  1589. (when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry))
  1590. (gnus-agent-flush-group (gnus-info-group entry)))))))
  1591. (defun gnus-agent-flush-group (group)
  1592. "Flush the agent's index files such that the GROUP no longer
  1593. appears to have any local content. The actual content, the
  1594. article files, may then be deleted using gnus-agent-expire-group.
  1595. If flushing was a mistake, the gnus-agent-regenerate-group method
  1596. provides an undo mechanism by reconstructing the index files from
  1597. the article files."
  1598. (interactive (list (gnus-agent-read-group)))
  1599. (let* ((gnus-command-method (or gnus-command-method
  1600. (gnus-find-method-for-group group)))
  1601. (overview (gnus-agent-article-name ".overview" group))
  1602. (agentview (gnus-agent-article-name ".agentview" group))
  1603. (file-name-coding-system nnmail-pathname-coding-system))
  1604. (if (file-exists-p overview)
  1605. (delete-file overview))
  1606. (if (file-exists-p agentview)
  1607. (delete-file agentview))
  1608. (gnus-agent-update-view-total-fetched-for group nil gnus-command-method)
  1609. (gnus-agent-update-view-total-fetched-for group t gnus-command-method)
  1610. ;(gnus-agent-set-local group nil nil)
  1611. ;(gnus-agent-save-local t)
  1612. (gnus-agent-save-group-info nil group nil)))
  1613. (defun gnus-agent-flush-cache ()
  1614. "Flush the agent's index files such that the group no longer
  1615. appears to have any local content. The actual content, the
  1616. article files, is then deleted using gnus-agent-expire-group. The
  1617. gnus-agent-regenerate-group method provides an undo mechanism by
  1618. reconstructing the index files from the article files."
  1619. (interactive)
  1620. (save-excursion
  1621. (let ((file-name-coding-system nnmail-pathname-coding-system))
  1622. (while gnus-agent-buffer-alist
  1623. (set-buffer (cdar gnus-agent-buffer-alist))
  1624. (let ((coding-system-for-write gnus-agent-file-coding-system))
  1625. (write-region (point-min) (point-max)
  1626. (gnus-agent-article-name ".overview"
  1627. (caar gnus-agent-buffer-alist))
  1628. nil 'silent))
  1629. (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist)))
  1630. (while gnus-agent-group-alist
  1631. (with-temp-file (gnus-agent-article-name
  1632. ".agentview" (caar gnus-agent-group-alist))
  1633. (princ (cdar gnus-agent-group-alist))
  1634. (insert "\n")
  1635. (princ 1 (current-buffer))
  1636. (insert "\n"))
  1637. (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))))
  1638. ;;;###autoload
  1639. (defun gnus-agent-find-parameter (group symbol)
  1640. "Search for GROUPs SYMBOL in the group's parameters, the group's
  1641. topic parameters, the group's category, or the customizable
  1642. variables. Returns the first non-nil value found."
  1643. (or (gnus-group-find-parameter group symbol t)
  1644. (gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t)
  1645. (symbol-value
  1646. (cdr
  1647. (assq symbol
  1648. '((agent-short-article . gnus-agent-short-article)
  1649. (agent-long-article . gnus-agent-long-article)
  1650. (agent-low-score . gnus-agent-low-score)
  1651. (agent-high-score . gnus-agent-high-score)
  1652. (agent-days-until-old . gnus-agent-expire-days)
  1653. (agent-enable-expiration
  1654. . gnus-agent-enable-expiration)
  1655. (agent-predicate . gnus-agent-predicate)))))))
  1656. (defun gnus-agent-fetch-headers (group &optional force)
  1657. "Fetch interesting headers into the agent. The group's overview
  1658. file will be updated to include the headers while a list of available
  1659. article numbers will be returned."
  1660. (let* ((fetch-all (and gnus-agent-consider-all-articles
  1661. ;; Do not fetch all headers if the predicate
  1662. ;; implies that we only consider unread articles.
  1663. (not (gnus-predicate-implies-unread
  1664. (gnus-agent-find-parameter group
  1665. 'agent-predicate)))))
  1666. (articles (if fetch-all
  1667. (if gnus-newsgroup-maximum-articles
  1668. (let ((active (gnus-active group)))
  1669. (gnus-uncompress-range
  1670. (cons (max (car active)
  1671. (- (cdr active)
  1672. gnus-newsgroup-maximum-articles
  1673. -1))
  1674. (cdr active))))
  1675. (gnus-uncompress-range (gnus-active group)))
  1676. (gnus-list-of-unread-articles group)))
  1677. (gnus-decode-encoded-word-function 'identity)
  1678. (gnus-decode-encoded-address-function 'identity)
  1679. (file (gnus-agent-article-name ".overview" group))
  1680. (file-name-coding-system nnmail-pathname-coding-system))
  1681. (unless fetch-all
  1682. ;; Add articles with marks to the list of article headers we want to
  1683. ;; fetch. Don't fetch articles solely on the basis of a recent or seen
  1684. ;; mark, but do fetch recent or seen articles if they have other, more
  1685. ;; interesting marks. (We have to fetch articles with boring marks
  1686. ;; because otherwise the agent will remove their marks.)
  1687. (dolist (arts (gnus-info-marks (gnus-get-info group)))
  1688. (unless (memq (car arts) '(seen recent killed cache))
  1689. (setq articles (gnus-range-add articles (cdr arts)))))
  1690. (setq articles (sort (gnus-uncompress-sequence articles) '<)))
  1691. ;; At this point, I have the list of articles to consider for
  1692. ;; fetching. This is the list that I'll return to my caller. Some
  1693. ;; of these articles may have already been fetched. That's OK as
  1694. ;; the fetch article code will filter those out. Internally, I'll
  1695. ;; filter this list to just those articles whose headers need to
  1696. ;; be fetched.
  1697. (let ((articles articles))
  1698. ;; Remove known articles.
  1699. (when (and (or gnus-agent-cache
  1700. (not gnus-plugged))
  1701. (gnus-agent-load-alist group))
  1702. ;; Remove articles marked as downloaded.
  1703. (if fetch-all
  1704. ;; I want to fetch all headers in the active range.
  1705. ;; Therefore, exclude only those headers that are in the
  1706. ;; article alist.
  1707. ;; NOTE: This is probably NOT what I want to do after
  1708. ;; agent expiration in this group.
  1709. (setq articles (gnus-agent-uncached-articles articles group))
  1710. ;; I want to only fetch those headers that have never been
  1711. ;; fetched. Therefore, exclude all headers that are, or
  1712. ;; WERE, in the article alist.
  1713. (let ((low (1+ (caar (last gnus-agent-article-alist))))
  1714. (high (cdr (gnus-active group))))
  1715. ;; Low can be greater than High when the same group is
  1716. ;; fetched twice in the same session {The first fetch will
  1717. ;; fill the article alist such that (last
  1718. ;; gnus-agent-article-alist) equals (cdr (gnus-active
  1719. ;; group))}. The addition of one(the 1+ above) then
  1720. ;; forces Low to be greater than High. When this happens,
  1721. ;; gnus-list-range-intersection returns nil which
  1722. ;; indicates that no headers need to be fetched. -- Kevin
  1723. (setq articles (gnus-list-range-intersection
  1724. articles (list (cons low high)))))))
  1725. (when articles
  1726. (gnus-message
  1727. 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
  1728. (gnus-compress-sequence articles t)))
  1729. (with-current-buffer nntp-server-buffer
  1730. (if articles
  1731. (progn
  1732. (gnus-message 8 "Fetching headers for %s..."
  1733. (gnus-agent-decoded-group-name group))
  1734. ;; Fetch them.
  1735. (gnus-make-directory (nnheader-translate-file-chars
  1736. (file-name-directory file) t))
  1737. (unless (eq 'nov (gnus-retrieve-headers articles group))
  1738. (nnvirtual-convert-headers))
  1739. (gnus-agent-check-overview-buffer)
  1740. ;; Move these headers to the overview buffer so that
  1741. ;; gnus-agent-braid-nov can merge them with the contents
  1742. ;; of FILE.
  1743. (copy-to-buffer
  1744. gnus-agent-overview-buffer (point-min) (point-max))
  1745. ;; NOTE: Call g-a-brand-nov even when the file does not
  1746. ;; exist. As a minimum, it will validate the article
  1747. ;; numbers already in the buffer.
  1748. (gnus-agent-braid-nov group articles file)
  1749. (let ((coding-system-for-write
  1750. gnus-agent-file-coding-system))
  1751. (gnus-agent-check-overview-buffer)
  1752. (write-region (point-min) (point-max) file nil 'silent))
  1753. (gnus-agent-update-view-total-fetched-for group t)
  1754. (gnus-agent-save-alist group articles nil)
  1755. articles)
  1756. (ignore-errors
  1757. (erase-buffer)
  1758. (nnheader-insert-file-contents file)))))
  1759. articles))
  1760. (defsubst gnus-agent-read-article-number ()
  1761. "Reads the article number at point. Returns nil when a valid article number can not be read."
  1762. ;; It is unfortunate but the read function quietly overflows
  1763. ;; integer. As a result, I have to use string operations to test
  1764. ;; for overflow BEFORE calling read.
  1765. (when (looking-at "[0-9]+\t")
  1766. (let ((len (- (match-end 0) (match-beginning 0))))
  1767. (cond ((< len 9)
  1768. (read (current-buffer)))
  1769. ((= len 9)
  1770. ;; Many 9 digit base-10 numbers can be represented in a 27-bit int
  1771. ;; Back convert from int to string to ensure that this is one of them.
  1772. (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0))))
  1773. (num (read (current-buffer)))
  1774. (str2 (int-to-string num)))
  1775. (when (equal str1 str2)
  1776. num)))))))
  1777. (defsubst gnus-agent-copy-nov-line (article)
  1778. "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer."
  1779. (let (art b e)
  1780. (set-buffer gnus-agent-overview-buffer)
  1781. (while (and (not (eobp))
  1782. (or (not (setq art (gnus-agent-read-article-number)))
  1783. (< art article)))
  1784. (forward-line 1))
  1785. (beginning-of-line)
  1786. (if (or (eobp)
  1787. (not (eq article art)))
  1788. (set-buffer nntp-server-buffer)
  1789. (setq b (point))
  1790. (setq e (progn (forward-line 1) (point)))
  1791. (set-buffer nntp-server-buffer)
  1792. (insert-buffer-substring gnus-agent-overview-buffer b e))))
  1793. (defun gnus-agent-braid-nov (group articles file)
  1794. "Merge agent overview data with given file.
  1795. Takes unvalidated headers for ARTICLES from
  1796. `gnus-agent-overview-buffer' and validated headers from the given
  1797. FILE and places the combined valid headers into
  1798. `nntp-server-buffer'. This function can be used, when file
  1799. doesn't exist, to valid the overview buffer."
  1800. (let (start last)
  1801. (set-buffer gnus-agent-overview-buffer)
  1802. (goto-char (point-min))
  1803. (set-buffer nntp-server-buffer)
  1804. (erase-buffer)
  1805. (when (file-exists-p file)
  1806. (nnheader-insert-file-contents file))
  1807. (goto-char (point-max))
  1808. (forward-line -1)
  1809. (unless (or (= (point-min) (point-max))
  1810. (< (setq last (read (current-buffer))) (car articles)))
  1811. ;; Old and new overlap -- We do it the hard way.
  1812. (when (nnheader-find-nov-line (car articles))
  1813. ;; Replacing existing NOV entry
  1814. (delete-region (point) (progn (forward-line 1) (point))))
  1815. (gnus-agent-copy-nov-line (pop articles))
  1816. (ignore-errors
  1817. (while articles
  1818. (while (let ((art (read (current-buffer))))
  1819. (cond ((< art (car articles))
  1820. (forward-line 1)
  1821. t)
  1822. ((= art (car articles))
  1823. (beginning-of-line)
  1824. (delete-region
  1825. (point) (progn (forward-line 1) (point)))
  1826. nil)
  1827. (t
  1828. (beginning-of-line)
  1829. nil))))
  1830. (gnus-agent-copy-nov-line (pop articles)))))
  1831. (goto-char (point-max))
  1832. ;; Append the remaining lines
  1833. (when articles
  1834. (when last
  1835. (set-buffer gnus-agent-overview-buffer)
  1836. (setq start (point))
  1837. (set-buffer nntp-server-buffer))
  1838. (let ((p (point)))
  1839. (insert-buffer-substring gnus-agent-overview-buffer start)
  1840. (goto-char p))
  1841. (setq last (or last -134217728))
  1842. (while (catch 'problems
  1843. (let (sort art)
  1844. (while (not (eobp))
  1845. (setq art (gnus-agent-read-article-number))
  1846. (cond ((not art)
  1847. ;; Bad art num - delete this line
  1848. (beginning-of-line)
  1849. (delete-region (point) (progn (forward-line 1) (point))))
  1850. ((< art last)
  1851. ;; Art num out of order - enable sort
  1852. (setq sort t)
  1853. (forward-line 1))
  1854. ((= art last)
  1855. ;; Bad repeat of art number - delete this line
  1856. (beginning-of-line)
  1857. (delete-region (point) (progn (forward-line 1) (point))))
  1858. (t
  1859. ;; Good art num
  1860. (setq last art)
  1861. (forward-line 1))))
  1862. (when sort
  1863. ;; something is seriously wrong as we simply shouldn't see out-of-order data.
  1864. ;; First, we'll fix the sort.
  1865. (sort-numeric-fields 1 (point-min) (point-max))
  1866. ;; but now we have to consider that we may have duplicate rows...
  1867. ;; so reset to beginning of file
  1868. (goto-char (point-min))
  1869. (setq last -134217728)
  1870. ;; and throw a code that restarts this scan
  1871. (throw 'problems t))
  1872. nil))))))
  1873. ;; Keeps the compiler from warning about the free variable in
  1874. ;; gnus-agent-read-agentview.
  1875. (defvar gnus-agent-read-agentview)
  1876. (defun gnus-agent-load-alist (group)
  1877. "Load the article-state alist for GROUP."
  1878. ;; Bind free variable that's used in `gnus-agent-read-agentview'.
  1879. (let* ((gnus-agent-read-agentview group)
  1880. (file-name-coding-system nnmail-pathname-coding-system)
  1881. (agentview (gnus-agent-article-name ".agentview" group)))
  1882. (setq gnus-agent-article-alist
  1883. (and (file-exists-p agentview)
  1884. (gnus-cache-file-contents
  1885. agentview
  1886. 'gnus-agent-file-loading-cache
  1887. 'gnus-agent-read-agentview)))))
  1888. (defun gnus-agent-read-agentview (file)
  1889. "Load FILE and do a `read' there."
  1890. (with-temp-buffer
  1891. (condition-case nil
  1892. (progn
  1893. (nnheader-insert-file-contents file)
  1894. (goto-char (point-min))
  1895. (let ((alist (read (current-buffer)))
  1896. (version (condition-case nil (read (current-buffer))
  1897. (end-of-file 0)))
  1898. changed-version)
  1899. (cond
  1900. ((= version 0)
  1901. (let ((inhibit-quit t)
  1902. entry)
  1903. (gnus-agent-open-history)
  1904. (set-buffer (gnus-agent-history-buffer))
  1905. (goto-char (point-min))
  1906. (while (not (eobp))
  1907. (if (and (looking-at
  1908. "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)")
  1909. (string= (match-string 2)
  1910. gnus-agent-read-agentview)
  1911. (setq entry (assoc (string-to-number (match-string 3)) alist)))
  1912. (setcdr entry (string-to-number (match-string 1))))
  1913. (forward-line 1))
  1914. (gnus-agent-close-history)
  1915. (setq changed-version t)))
  1916. ((= version 1)
  1917. (setq changed-version (not (= 1 gnus-agent-article-alist-save-format))))
  1918. ((= version 2)
  1919. (let (state sequence uncomp)
  1920. (while alist
  1921. (setq state (caar alist)
  1922. sequence (inline (gnus-uncompress-range (cdar alist)))
  1923. alist (cdr alist))
  1924. (while sequence
  1925. (push (cons (pop sequence) state) uncomp)))
  1926. (setq alist (sort uncomp 'car-less-than-car)))
  1927. (setq changed-version (not (= 2 gnus-agent-article-alist-save-format)))))
  1928. (when changed-version
  1929. (let ((gnus-agent-article-alist alist))
  1930. (gnus-agent-save-alist gnus-agent-read-agentview)))
  1931. alist))
  1932. ((end-of-file file-error)
  1933. ;; The agentview file is missing.
  1934. (condition-case nil
  1935. ;; If the agent directory exists, attempt to perform a brute-force
  1936. ;; reconstruction of its contents.
  1937. (let* (alist
  1938. (file-name-coding-system nnmail-pathname-coding-system)
  1939. (file-attributes (directory-files-and-attributes
  1940. (gnus-agent-article-name ""
  1941. gnus-agent-read-agentview) nil "^[0-9]+$" t)))
  1942. (while file-attributes
  1943. (let ((fa (pop file-attributes)))
  1944. (unless (nth 1 fa)
  1945. (push (cons (string-to-number (nth 0 fa)) (time-to-days (nth 5 fa))) alist))))
  1946. alist)
  1947. (file-error nil))))))
  1948. (defun gnus-agent-save-alist (group &optional articles state)
  1949. "Save the article-state alist for GROUP."
  1950. (let* ((file-name-coding-system nnmail-pathname-coding-system)
  1951. (prev (cons nil gnus-agent-article-alist))
  1952. (all prev)
  1953. print-level print-length item article)
  1954. (while (setq article (pop articles))
  1955. (while (and (cdr prev)
  1956. (< (caadr prev) article))
  1957. (setq prev (cdr prev)))
  1958. (cond
  1959. ((not (cdr prev))
  1960. (setcdr prev (list (cons article state))))
  1961. ((> (caadr prev) article)
  1962. (setcdr prev (cons (cons article state) (cdr prev))))
  1963. ((= (caadr prev) article)
  1964. (setcdr (cadr prev) state)))
  1965. (setq prev (cdr prev)))
  1966. (setq gnus-agent-article-alist (cdr all))
  1967. (gnus-agent-set-local group
  1968. (caar gnus-agent-article-alist)
  1969. (caar (last gnus-agent-article-alist)))
  1970. (gnus-make-directory (gnus-agent-article-name "" group))
  1971. (with-temp-file (gnus-agent-article-name ".agentview" group)
  1972. (cond ((eq gnus-agent-article-alist-save-format 1)
  1973. (princ gnus-agent-article-alist (current-buffer)))
  1974. ((eq gnus-agent-article-alist-save-format 2)
  1975. (let ((alist gnus-agent-article-alist)
  1976. article-id day-of-download comp-list compressed)
  1977. (while alist
  1978. (setq article-id (caar alist)
  1979. day-of-download (cdar alist)
  1980. comp-list (assq day-of-download compressed)
  1981. alist (cdr alist))
  1982. (if comp-list
  1983. (setcdr comp-list (cons article-id (cdr comp-list)))
  1984. (push (list day-of-download article-id) compressed)))
  1985. (setq alist compressed)
  1986. (while alist
  1987. (setq comp-list (pop alist))
  1988. (setcdr comp-list
  1989. (gnus-compress-sequence (nreverse (cdr comp-list)))))
  1990. (princ compressed (current-buffer)))))
  1991. (insert "\n")
  1992. (princ gnus-agent-article-alist-save-format (current-buffer))
  1993. (insert "\n"))
  1994. (gnus-agent-update-view-total-fetched-for group nil)))
  1995. (defvar gnus-agent-article-local nil)
  1996. (defvar gnus-agent-article-local-times nil)
  1997. (defvar gnus-agent-file-loading-local nil)
  1998. (defun gnus-agent-load-local (&optional method)
  1999. "Load the METHOD'S local file. The local file contains min/max
  2000. article counts for each of the method's subscribed groups."
  2001. (let ((gnus-command-method (or method gnus-command-method)))
  2002. (when (or (null gnus-agent-article-local-times)
  2003. (zerop gnus-agent-article-local-times)
  2004. (not (gnus-methods-equal-p
  2005. gnus-command-method
  2006. (symbol-value (intern "+method" gnus-agent-article-local)))))
  2007. (setq gnus-agent-article-local
  2008. (gnus-cache-file-contents
  2009. (gnus-agent-lib-file "local")
  2010. 'gnus-agent-file-loading-local
  2011. 'gnus-agent-read-and-cache-local))
  2012. (when gnus-agent-article-local-times
  2013. (incf gnus-agent-article-local-times)))
  2014. gnus-agent-article-local))
  2015. (defun gnus-agent-read-and-cache-local (file)
  2016. "Load and read FILE then bind its contents to
  2017. gnus-agent-article-local. If that variable had `dirty' (also known as
  2018. modified) original contents, they are first saved to their own file."
  2019. (if (and gnus-agent-article-local
  2020. (symbol-value (intern "+dirty" gnus-agent-article-local)))
  2021. (gnus-agent-save-local))
  2022. (gnus-agent-read-local file))
  2023. (defun gnus-agent-read-local (file)
  2024. "Load FILE and do a `read' there."
  2025. (let ((my-obarray (gnus-make-hashtable (count-lines (point-min)
  2026. (point-max))))
  2027. (line 1))
  2028. (with-temp-buffer
  2029. (condition-case nil
  2030. (let ((nnheader-file-coding-system gnus-agent-file-coding-system))
  2031. (nnheader-insert-file-contents file))
  2032. (file-error))
  2033. (goto-char (point-min))
  2034. ;; Skip any comments at the beginning of the file (the only place where they may appear)
  2035. (while (= (following-char) ?\;)
  2036. (forward-line 1)
  2037. (setq line (1+ line)))
  2038. (while (not (eobp))
  2039. (condition-case err
  2040. (let (group
  2041. min
  2042. max
  2043. (cur (current-buffer))
  2044. (obarray my-obarray))
  2045. (setq group (read cur)
  2046. min (read cur)
  2047. max (read cur))
  2048. (when (stringp group)
  2049. (setq group (intern group my-obarray)))
  2050. ;; NOTE: The '+ 0' ensure that min and max are both numerics.
  2051. (set group (cons (+ 0 min) (+ 0 max))))
  2052. (error
  2053. (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s"
  2054. file line (error-message-string err))))
  2055. (forward-line 1)
  2056. (setq line (1+ line))))
  2057. (set (intern "+dirty" my-obarray) nil)
  2058. (set (intern "+method" my-obarray) gnus-command-method)
  2059. my-obarray))
  2060. (defun gnus-agent-save-local (&optional force)
  2061. "Save gnus-agent-article-local under it method's agent.lib directory."
  2062. (let ((my-obarray gnus-agent-article-local))
  2063. (when (and my-obarray
  2064. (or force (symbol-value (intern "+dirty" my-obarray))))
  2065. (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
  2066. ;; NOTE: gnus-command-method is used within gnus-agent-lib-file.
  2067. (dest (gnus-agent-lib-file "local")))
  2068. (gnus-make-directory (gnus-agent-lib-file ""))
  2069. (let ((coding-system-for-write gnus-agent-file-coding-system)
  2070. (file-name-coding-system nnmail-pathname-coding-system))
  2071. (with-temp-file dest
  2072. (let ((gnus-command-method (symbol-value (intern "+method" my-obarray)))
  2073. print-level print-length item article
  2074. (standard-output (current-buffer)))
  2075. (mapatoms (lambda (symbol)
  2076. (cond ((not (boundp symbol))
  2077. nil)
  2078. ((member (symbol-name symbol) '("+dirty" "+method"))
  2079. nil)
  2080. (t
  2081. (let ((range (symbol-value symbol)))
  2082. (when range
  2083. (prin1 symbol)
  2084. (princ " ")
  2085. (princ (car range))
  2086. (princ " ")
  2087. (princ (cdr range))
  2088. (princ "\n"))))))
  2089. my-obarray))))))))
  2090. (defun gnus-agent-get-local (group &optional gmane method)
  2091. (let* ((gmane (or gmane (gnus-group-real-name group)))
  2092. (gnus-command-method (or method (gnus-find-method-for-group group)))
  2093. (local (gnus-agent-load-local))
  2094. (symb (intern gmane local))
  2095. (minmax (and (boundp symb) (symbol-value symb))))
  2096. (unless minmax
  2097. ;; Bind these so that gnus-agent-load-alist doesn't change the
  2098. ;; current alist (i.e. gnus-agent-article-alist)
  2099. (let* ((gnus-agent-article-alist gnus-agent-article-alist)
  2100. (gnus-agent-file-loading-cache gnus-agent-file-loading-cache)
  2101. (alist (gnus-agent-load-alist group)))
  2102. (when alist
  2103. (setq minmax
  2104. (cons (caar alist)
  2105. (caar (last alist))))
  2106. (gnus-agent-set-local group (car minmax) (cdr minmax)
  2107. gmane gnus-command-method local))))
  2108. minmax))
  2109. (defun gnus-agent-set-local (group min max &optional gmane method local)
  2110. (let* ((gmane (or gmane (gnus-group-real-name group)))
  2111. (gnus-command-method (or method (gnus-find-method-for-group group)))
  2112. (local (or local (gnus-agent-load-local)))
  2113. (symb (intern gmane local))
  2114. (minmax (and (boundp symb) (symbol-value symb))))
  2115. (if (cond ((and minmax
  2116. (or (not (eq min (car minmax)))
  2117. (not (eq max (cdr minmax))))
  2118. min
  2119. max)
  2120. (setcar minmax min)
  2121. (setcdr minmax max)
  2122. t)
  2123. (minmax
  2124. nil)
  2125. ((and min max)
  2126. (set symb (cons min max))
  2127. t)
  2128. (t
  2129. (unintern symb local)))
  2130. (set (intern "+dirty" local) t))))
  2131. (defun gnus-agent-article-name (article group)
  2132. (expand-file-name article
  2133. (file-name-as-directory
  2134. (gnus-agent-group-pathname group))))
  2135. (defun gnus-agent-batch-confirmation (msg)
  2136. "Show error message and return t."
  2137. (gnus-message 1 "%s" msg)
  2138. t)
  2139. ;;;###autoload
  2140. (defun gnus-agent-batch-fetch ()
  2141. "Start Gnus and fetch session."
  2142. (interactive)
  2143. (gnus)
  2144. (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
  2145. (gnus-agent-fetch-session))
  2146. (gnus-group-exit))
  2147. (defun gnus-agent-fetch-session ()
  2148. "Fetch all articles and headers that are eligible for fetching."
  2149. (interactive)
  2150. (unless gnus-agent-covered-methods
  2151. (error "No servers are covered by the Gnus agent"))
  2152. (unless gnus-plugged
  2153. (error "Can't fetch articles while Gnus is unplugged"))
  2154. (let ((methods (gnus-agent-covered-methods))
  2155. groups group gnus-command-method)
  2156. (save-excursion
  2157. (while methods
  2158. (setq gnus-command-method (car methods))
  2159. (when (and (or (gnus-server-opened gnus-command-method)
  2160. (gnus-open-server gnus-command-method))
  2161. (gnus-online gnus-command-method))
  2162. (setq groups (gnus-groups-from-server (car methods)))
  2163. (gnus-agent-with-fetch
  2164. (while (setq group (pop groups))
  2165. (when (<= (gnus-group-level group)
  2166. gnus-agent-handle-level)
  2167. (if (or debug-on-error debug-on-quit)
  2168. (gnus-agent-fetch-group-1
  2169. group gnus-command-method)
  2170. (condition-case err
  2171. (gnus-agent-fetch-group-1
  2172. group gnus-command-method)
  2173. (error
  2174. (unless (funcall gnus-agent-confirmation-function
  2175. (format "Error %s while fetching session. Should gnus continue? "
  2176. (error-message-string err)))
  2177. (error "Cannot fetch articles into the Gnus agent")))
  2178. (quit
  2179. (gnus-agent-regenerate-group group)
  2180. (unless (funcall gnus-agent-confirmation-function
  2181. (format
  2182. "%s while fetching session. Should gnus continue? "
  2183. (error-message-string err)))
  2184. (signal 'quit
  2185. "Cannot fetch articles into the Gnus agent")))))))))
  2186. (setq methods (cdr methods)))
  2187. (gnus-run-hooks 'gnus-agent-fetched-hook)
  2188. (gnus-message 6 "Finished fetching articles into the Gnus agent"))))
  2189. (defun gnus-agent-fetch-group-1 (group method)
  2190. "Fetch GROUP."
  2191. (let ((gnus-command-method method)
  2192. (gnus-newsgroup-name group)
  2193. (gnus-newsgroup-dependencies gnus-newsgroup-dependencies)
  2194. (gnus-newsgroup-headers gnus-newsgroup-headers)
  2195. (gnus-newsgroup-scored gnus-newsgroup-scored)
  2196. (gnus-use-cache gnus-use-cache)
  2197. (gnus-summary-expunge-below gnus-summary-expunge-below)
  2198. (gnus-summary-mark-below gnus-summary-mark-below)
  2199. (gnus-orphan-score gnus-orphan-score)
  2200. ;; Maybe some other gnus-summary local variables should also
  2201. ;; be put here.
  2202. gnus-headers
  2203. gnus-score
  2204. articles arts
  2205. category predicate info marks score-param
  2206. )
  2207. (unless (gnus-check-group group)
  2208. (error "Can't open server for %s" group))
  2209. ;; Fetch headers.
  2210. (when (or gnus-newsgroup-active
  2211. (gnus-active group)
  2212. (gnus-activate-group group))
  2213. (let ((marked-articles gnus-newsgroup-downloadable))
  2214. ;; Identify the articles marked for download
  2215. (unless gnus-newsgroup-active
  2216. ;; The variable gnus-newsgroup-active was selected as I need
  2217. ;; a gnus-summary local variable that is NOT bound to any
  2218. ;; value (its global value should default to nil).
  2219. (dolist (mark gnus-agent-download-marks)
  2220. (let ((arts (cdr (assq mark (gnus-info-marks
  2221. (setq info (gnus-get-info group)))))))
  2222. (when arts
  2223. (setq marked-articles (nconc (gnus-uncompress-range arts)
  2224. marked-articles))
  2225. ))))
  2226. (setq marked-articles (sort marked-articles '<))
  2227. ;; Fetch any new articles from the server
  2228. (setq articles (gnus-agent-fetch-headers group))
  2229. ;; Merge new articles with marked
  2230. (setq articles (sort (append marked-articles articles) '<))
  2231. (when articles
  2232. ;; Parse them and see which articles we want to fetch.
  2233. (setq gnus-newsgroup-dependencies
  2234. (or gnus-newsgroup-dependencies
  2235. (make-vector (length articles) 0)))
  2236. (setq gnus-newsgroup-headers
  2237. (or gnus-newsgroup-headers
  2238. (gnus-get-newsgroup-headers-xover articles nil nil
  2239. group)))
  2240. ;; `gnus-agent-overview-buffer' may be killed for
  2241. ;; timeout reason. If so, recreate it.
  2242. (gnus-agent-create-buffer)
  2243. ;; Figure out how to select articles in this group
  2244. (setq category (gnus-group-category group))
  2245. (setq predicate
  2246. (gnus-get-predicate
  2247. (gnus-agent-find-parameter group 'agent-predicate)))
  2248. ;; If the selection predicate requires scoring, score each header
  2249. (unless (memq predicate '(gnus-agent-true gnus-agent-false))
  2250. (let ((score-param
  2251. (gnus-agent-find-parameter group 'agent-score-file)))
  2252. ;; Translate score-param into real one
  2253. (cond
  2254. ((not score-param))
  2255. ((eq score-param 'file)
  2256. (setq score-param (gnus-all-score-files group)))
  2257. ((stringp (car score-param)))
  2258. (t
  2259. (setq score-param (list (list score-param)))))
  2260. (when score-param
  2261. (gnus-score-headers score-param))))
  2262. (unless (and (eq predicate 'gnus-agent-false)
  2263. (not marked-articles))
  2264. (let ((arts (list nil)))
  2265. (let ((arts-tail arts)
  2266. (alist (gnus-agent-load-alist group))
  2267. (marked-articles marked-articles)
  2268. (gnus-newsgroup-headers gnus-newsgroup-headers))
  2269. (while (setq gnus-headers (pop gnus-newsgroup-headers))
  2270. (let ((num (mail-header-number gnus-headers)))
  2271. ;; Determine if this article is already in the cache
  2272. (while (and alist
  2273. (> num (caar alist)))
  2274. (setq alist (cdr alist)))
  2275. (unless (and (eq num (caar alist))
  2276. (cdar alist))
  2277. ;; Determine if this article was marked for download.
  2278. (while (and marked-articles
  2279. (> num (car marked-articles)))
  2280. (setq marked-articles
  2281. (cdr marked-articles)))
  2282. ;; When this article is marked, or selected by the
  2283. ;; predicate, add it to the download list
  2284. (when (or (eq num (car marked-articles))
  2285. (let ((gnus-score
  2286. (or (cdr
  2287. (assq num gnus-newsgroup-scored))
  2288. gnus-summary-default-score))
  2289. (gnus-agent-long-article
  2290. (gnus-agent-find-parameter
  2291. group 'agent-long-article))
  2292. (gnus-agent-short-article
  2293. (gnus-agent-find-parameter
  2294. group 'agent-short-article))
  2295. (gnus-agent-low-score
  2296. (gnus-agent-find-parameter
  2297. group 'agent-low-score))
  2298. (gnus-agent-high-score
  2299. (gnus-agent-find-parameter
  2300. group 'agent-high-score))
  2301. (gnus-agent-expire-days
  2302. (gnus-agent-find-parameter
  2303. group 'agent-days-until-old)))
  2304. (funcall predicate)))
  2305. (gnus-agent-append-to-list arts-tail num))))))
  2306. (let (fetched-articles)
  2307. ;; Fetch all selected articles
  2308. (setq gnus-newsgroup-undownloaded
  2309. (gnus-sorted-ndifference
  2310. gnus-newsgroup-undownloaded
  2311. (setq fetched-articles
  2312. (if (cdr arts)
  2313. (gnus-agent-fetch-articles group (cdr arts))
  2314. nil))))
  2315. (let ((unfetched-articles
  2316. (gnus-sorted-ndifference (cdr arts) fetched-articles)))
  2317. (if gnus-newsgroup-active
  2318. ;; Update the summary buffer
  2319. (progn
  2320. (dolist (article marked-articles)
  2321. (gnus-summary-set-agent-mark article t))
  2322. (dolist (article fetched-articles)
  2323. (when gnus-agent-mark-unread-after-downloaded
  2324. (setq gnus-newsgroup-downloadable
  2325. (delq article gnus-newsgroup-downloadable))
  2326. (gnus-summary-mark-article
  2327. article gnus-unread-mark))
  2328. (when (gnus-summary-goto-subject article nil t)
  2329. (gnus-summary-update-download-mark article)))
  2330. (dolist (article unfetched-articles)
  2331. (gnus-summary-mark-article
  2332. article gnus-canceled-mark)))
  2333. ;; Update the group buffer.
  2334. ;; When some, or all, of the marked articles came
  2335. ;; from the download mark. Remove that mark. I
  2336. ;; didn't do this earlier as I only want to remove
  2337. ;; the marks after the fetch is completed.
  2338. (dolist (mark gnus-agent-download-marks)
  2339. (when (eq mark 'download)
  2340. (let ((marked-arts
  2341. (assq mark (gnus-info-marks
  2342. (setq info (gnus-get-info group))))))
  2343. (when (cdr marked-arts)
  2344. (setq marks
  2345. (delq marked-arts (gnus-info-marks info)))
  2346. (gnus-info-set-marks info marks)))))
  2347. (let ((read (gnus-info-read
  2348. (or info (setq info (gnus-get-info group))))))
  2349. (gnus-info-set-read
  2350. info (gnus-add-to-range read unfetched-articles)))
  2351. (gnus-group-update-group group t)
  2352. (sit-for 0)
  2353. (gnus-dribble-enter
  2354. (concat "(gnus-group-set-info '"
  2355. (gnus-prin1-to-string info)
  2356. ")")
  2357. (concat "^(gnus-group-set-info '(\""
  2358. (regexp-quote group) "\""))))))))))))
  2359. ;;;
  2360. ;;; Agent Category Mode
  2361. ;;;
  2362. (defvar gnus-category-mode-hook nil
  2363. "Hook run in `gnus-category-mode' buffers.")
  2364. (defvar gnus-category-line-format " %(%20c%): %g\n"
  2365. "Format of category lines.
  2366. Valid specifiers include:
  2367. %c Topic name (string)
  2368. %g The number of groups in the topic (integer)
  2369. General format specifiers can also be used. See Info node
  2370. `(gnus)Formatting Variables'.")
  2371. (defvar gnus-category-mode-line-format "Gnus: %%b"
  2372. "The format specification for the category mode line.")
  2373. (defvar gnus-agent-predicate 'false
  2374. "The selection predicate used when no other source is available.")
  2375. (defvar gnus-agent-short-article 500
  2376. "Articles that have fewer lines than this are short.")
  2377. (defvar gnus-agent-long-article 1000
  2378. "Articles that have more lines than this are long.")
  2379. (defvar gnus-agent-low-score 0
  2380. "Articles that have a score lower than this have a low score.")
  2381. (defvar gnus-agent-high-score 0
  2382. "Articles that have a score higher than this have a high score.")
  2383. ;;; Internal variables.
  2384. (defvar gnus-category-buffer "*Agent Category*")
  2385. (defvar gnus-category-line-format-alist
  2386. `((?c gnus-tmp-name ?s)
  2387. (?g gnus-tmp-groups ?d)))
  2388. (defvar gnus-category-mode-line-format-alist
  2389. `((?u user-defined ?s)))
  2390. (defvar gnus-category-line-format-spec nil)
  2391. (defvar gnus-category-mode-line-format-spec nil)
  2392. (defvar gnus-category-mode-map nil)
  2393. (put 'gnus-category-mode 'mode-class 'special)
  2394. (unless gnus-category-mode-map
  2395. (setq gnus-category-mode-map (make-sparse-keymap))
  2396. (suppress-keymap gnus-category-mode-map)
  2397. (gnus-define-keys gnus-category-mode-map
  2398. "q" gnus-category-exit
  2399. "k" gnus-category-kill
  2400. "c" gnus-category-copy
  2401. "a" gnus-category-add
  2402. "e" gnus-agent-customize-category
  2403. "p" gnus-category-edit-predicate
  2404. "g" gnus-category-edit-groups
  2405. "s" gnus-category-edit-score
  2406. "l" gnus-category-list
  2407. "\C-c\C-i" gnus-info-find-node
  2408. "\C-c\C-b" gnus-bug))
  2409. (defvar gnus-category-menu-hook nil
  2410. "*Hook run after the creation of the menu.")
  2411. (defun gnus-category-make-menu-bar ()
  2412. (gnus-turn-off-edit-menu 'category)
  2413. (unless (boundp 'gnus-category-menu)
  2414. (easy-menu-define
  2415. gnus-category-menu gnus-category-mode-map ""
  2416. '("Categories"
  2417. ["Add" gnus-category-add t]
  2418. ["Kill" gnus-category-kill t]
  2419. ["Copy" gnus-category-copy t]
  2420. ["Edit category" gnus-agent-customize-category t]
  2421. ["Edit predicate" gnus-category-edit-predicate t]
  2422. ["Edit score" gnus-category-edit-score t]
  2423. ["Edit groups" gnus-category-edit-groups t]
  2424. ["Exit" gnus-category-exit t]))
  2425. (gnus-run-hooks 'gnus-category-menu-hook)))
  2426. (defun gnus-category-mode ()
  2427. "Major mode for listing and editing agent categories.
  2428. All normal editing commands are switched off.
  2429. \\<gnus-category-mode-map>
  2430. For more in-depth information on this mode, read the manual
  2431. \(`\\[gnus-info-find-node]').
  2432. The following commands are available:
  2433. \\{gnus-category-mode-map}"
  2434. (interactive)
  2435. (when (gnus-visual-p 'category-menu 'menu)
  2436. (gnus-category-make-menu-bar))
  2437. (kill-all-local-variables)
  2438. (gnus-simplify-mode-line)
  2439. (setq major-mode 'gnus-category-mode)
  2440. (setq mode-name "Category")
  2441. (gnus-set-default-directory)
  2442. (setq mode-line-process nil)
  2443. (use-local-map gnus-category-mode-map)
  2444. (buffer-disable-undo)
  2445. (setq truncate-lines t)
  2446. (setq buffer-read-only t)
  2447. (gnus-run-mode-hooks 'gnus-category-mode-hook))
  2448. (defalias 'gnus-category-position-point 'gnus-goto-colon)
  2449. (defun gnus-category-insert-line (category)
  2450. (let* ((gnus-tmp-name (format "%s" (car category)))
  2451. (gnus-tmp-groups (length (gnus-agent-cat-groups category))))
  2452. (beginning-of-line)
  2453. (gnus-add-text-properties
  2454. (point)
  2455. (prog1 (1+ (point))
  2456. ;; Insert the text.
  2457. (eval gnus-category-line-format-spec))
  2458. (list 'gnus-category gnus-tmp-name))))
  2459. (defun gnus-enter-category-buffer ()
  2460. "Go to the Category buffer."
  2461. (interactive)
  2462. (gnus-category-setup-buffer)
  2463. (gnus-configure-windows 'category)
  2464. (gnus-category-prepare))
  2465. (defun gnus-category-setup-buffer ()
  2466. (unless (get-buffer gnus-category-buffer)
  2467. (with-current-buffer (gnus-get-buffer-create gnus-category-buffer)
  2468. (gnus-category-mode))))
  2469. (defun gnus-category-prepare ()
  2470. (gnus-set-format 'category-mode)
  2471. (gnus-set-format 'category t)
  2472. (let ((alist gnus-category-alist)
  2473. (buffer-read-only nil))
  2474. (erase-buffer)
  2475. (while alist
  2476. (gnus-category-insert-line (pop alist)))
  2477. (goto-char (point-min))
  2478. (gnus-category-position-point)))
  2479. (defun gnus-category-name ()
  2480. (or (intern (get-text-property (point-at-bol) 'gnus-category))
  2481. (error "No category on the current line")))
  2482. (defun gnus-category-read ()
  2483. "Read the category alist."
  2484. (setq gnus-category-alist
  2485. (or
  2486. (with-temp-buffer
  2487. (ignore-errors
  2488. (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories"))
  2489. (goto-char (point-min))
  2490. ;; This code isn't temp, it will be needed so long as
  2491. ;; anyone may be migrating from an older version.
  2492. ;; Once we're certain that people will not revert to an
  2493. ;; earlier version, we can take out the old-list code in
  2494. ;; gnus-category-write.
  2495. (let* ((old-list (read (current-buffer)))
  2496. (new-list (ignore-errors (read (current-buffer)))))
  2497. (if new-list
  2498. new-list
  2499. ;; Convert from a positional list to an alist.
  2500. (mapcar
  2501. (lambda (c)
  2502. (setcdr c
  2503. (delq nil
  2504. (gnus-mapcar
  2505. (lambda (valu symb)
  2506. (if valu
  2507. (cons symb valu)))
  2508. (cdr c)
  2509. '(agent-predicate agent-score-file agent-groups))))
  2510. c)
  2511. old-list)))))
  2512. (list (gnus-agent-cat-make 'default 'short)))))
  2513. (defun gnus-category-write ()
  2514. "Write the category alist."
  2515. (setq gnus-category-predicate-cache nil
  2516. gnus-category-group-cache nil)
  2517. (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
  2518. (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories")
  2519. ;; This prin1 is temporary. It exists so that people can revert
  2520. ;; to an earlier version of gnus-agent.
  2521. (prin1 (mapcar (lambda (c)
  2522. (list (car c)
  2523. (cdr (assoc 'agent-predicate c))
  2524. (cdr (assoc 'agent-score-file c))
  2525. (cdr (assoc 'agent-groups c))))
  2526. gnus-category-alist)
  2527. (current-buffer))
  2528. (newline)
  2529. (prin1 gnus-category-alist (current-buffer))))
  2530. (defun gnus-category-edit-predicate (category)
  2531. "Edit the predicate for CATEGORY."
  2532. (interactive (list (gnus-category-name)))
  2533. (let ((info (assq category gnus-category-alist)))
  2534. (gnus-edit-form
  2535. (gnus-agent-cat-predicate info)
  2536. (format "Editing the select predicate for category %s" category)
  2537. `(lambda (predicate)
  2538. ;; Avoid run-time execution of setf form
  2539. ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist))
  2540. ;; predicate)
  2541. ;; use its expansion instead:
  2542. (gnus-agent-cat-set-property (assq ',category gnus-category-alist)
  2543. 'agent-predicate predicate)
  2544. (gnus-category-write)
  2545. (gnus-category-list)))))
  2546. (defun gnus-category-edit-score (category)
  2547. "Edit the score expression for CATEGORY."
  2548. (interactive (list (gnus-category-name)))
  2549. (let ((info (assq category gnus-category-alist)))
  2550. (gnus-edit-form
  2551. (gnus-agent-cat-score-file info)
  2552. (format "Editing the score expression for category %s" category)
  2553. `(lambda (score-file)
  2554. ;; Avoid run-time execution of setf form
  2555. ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist))
  2556. ;; score-file)
  2557. ;; use its expansion instead:
  2558. (gnus-agent-cat-set-property (assq ',category gnus-category-alist)
  2559. 'agent-score-file score-file)
  2560. (gnus-category-write)
  2561. (gnus-category-list)))))
  2562. (defun gnus-category-edit-groups (category)
  2563. "Edit the group list for CATEGORY."
  2564. (interactive (list (gnus-category-name)))
  2565. (let ((info (assq category gnus-category-alist)))
  2566. (gnus-edit-form
  2567. (gnus-agent-cat-groups info)
  2568. (format "Editing the group list for category %s" category)
  2569. `(lambda (groups)
  2570. ;; Avoid run-time execution of setf form
  2571. ;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist))
  2572. ;; groups)
  2573. ;; use its expansion instead:
  2574. (gnus-agent-set-cat-groups (assq ',category gnus-category-alist)
  2575. groups)
  2576. (gnus-category-write)
  2577. (gnus-category-list)))))
  2578. (defun gnus-category-kill (category)
  2579. "Kill the current category."
  2580. (interactive (list (gnus-category-name)))
  2581. (let ((info (assq category gnus-category-alist))
  2582. (buffer-read-only nil))
  2583. (gnus-delete-line)
  2584. (setq gnus-category-alist (delq info gnus-category-alist))
  2585. (gnus-category-write)))
  2586. (defun gnus-category-copy (category to)
  2587. "Copy the current category."
  2588. (interactive (list (gnus-category-name) (intern (read-string "New name: "))))
  2589. (let ((info (assq category gnus-category-alist)))
  2590. (push (let ((newcat (gnus-copy-sequence info)))
  2591. (setf (gnus-agent-cat-name newcat) to)
  2592. (setf (gnus-agent-cat-groups newcat) nil)
  2593. newcat)
  2594. gnus-category-alist)
  2595. (gnus-category-write)
  2596. (gnus-category-list)))
  2597. (defun gnus-category-add (category)
  2598. "Create a new category."
  2599. (interactive "SCategory name: ")
  2600. (when (assq category gnus-category-alist)
  2601. (error "Category %s already exists" category))
  2602. (push (gnus-agent-cat-make category)
  2603. gnus-category-alist)
  2604. (gnus-category-write)
  2605. (gnus-category-list))
  2606. (defun gnus-category-list ()
  2607. "List all categories."
  2608. (interactive)
  2609. (gnus-category-prepare))
  2610. (defun gnus-category-exit ()
  2611. "Return to the group buffer."
  2612. (interactive)
  2613. (kill-buffer (current-buffer))
  2614. (gnus-configure-windows 'group t))
  2615. ;; To avoid having 8-bit characters in the source file.
  2616. (defvar gnus-category-not (list '! 'not (intern (format "%c" 172))))
  2617. (defvar gnus-category-predicate-alist
  2618. '((spam . gnus-agent-spam-p)
  2619. (short . gnus-agent-short-p)
  2620. (long . gnus-agent-long-p)
  2621. (low . gnus-agent-low-scored-p)
  2622. (high . gnus-agent-high-scored-p)
  2623. (read . gnus-agent-read-p)
  2624. (true . gnus-agent-true)
  2625. (false . gnus-agent-false))
  2626. "Mapping from short score predicate symbols to predicate functions.")
  2627. (defun gnus-agent-spam-p ()
  2628. "Say whether an article is spam or not."
  2629. (unless gnus-agent-spam-hashtb
  2630. (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000)))
  2631. (if (not (equal (mail-header-references gnus-headers) ""))
  2632. nil
  2633. (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers))))
  2634. (prog1
  2635. (gnus-gethash string gnus-agent-spam-hashtb)
  2636. (gnus-sethash string t gnus-agent-spam-hashtb)))))
  2637. (defun gnus-agent-short-p ()
  2638. "Say whether an article is short or not."
  2639. (< (mail-header-lines gnus-headers) gnus-agent-short-article))
  2640. (defun gnus-agent-long-p ()
  2641. "Say whether an article is long or not."
  2642. (> (mail-header-lines gnus-headers) gnus-agent-long-article))
  2643. (defun gnus-agent-low-scored-p ()
  2644. "Say whether an article has a low score or not."
  2645. (< gnus-score gnus-agent-low-score))
  2646. (defun gnus-agent-high-scored-p ()
  2647. "Say whether an article has a high score or not."
  2648. (> gnus-score gnus-agent-high-score))
  2649. (defun gnus-agent-read-p ()
  2650. "Say whether an article is read or not."
  2651. (gnus-member-of-range (mail-header-number gnus-headers)
  2652. (gnus-info-read (gnus-get-info gnus-newsgroup-name))))
  2653. (defun gnus-category-make-function (predicate)
  2654. "Make a function from PREDICATE."
  2655. (let ((func (gnus-category-make-function-1 predicate)))
  2656. (if (and (= (length func) 1)
  2657. (symbolp (car func)))
  2658. (car func)
  2659. (gnus-byte-compile `(lambda () ,func)))))
  2660. (defun gnus-agent-true ()
  2661. "Return t."
  2662. t)
  2663. (defun gnus-agent-false ()
  2664. "Return nil."
  2665. nil)
  2666. (defun gnus-category-make-function-1 (predicate)
  2667. "Make a function from PREDICATE."
  2668. (cond
  2669. ;; Functions are just returned as is.
  2670. ((or (symbolp predicate)
  2671. (functionp predicate))
  2672. `(,(or (cdr (assq predicate gnus-category-predicate-alist))
  2673. predicate)))
  2674. ;; More complex predicate.
  2675. ((consp predicate)
  2676. `(,(cond
  2677. ((memq (car predicate) '(& and))
  2678. 'and)
  2679. ((memq (car predicate) '(| or))
  2680. 'or)
  2681. ((memq (car predicate) gnus-category-not)
  2682. 'not))
  2683. ,@(mapcar 'gnus-category-make-function-1 (cdr predicate))))
  2684. (t
  2685. (error "Unknown predicate type: %s" predicate))))
  2686. (defun gnus-get-predicate (predicate)
  2687. "Return the function implementing PREDICATE."
  2688. (or (cdr (assoc predicate gnus-category-predicate-cache))
  2689. (let ((func (gnus-category-make-function predicate)))
  2690. (setq gnus-category-predicate-cache
  2691. (nconc gnus-category-predicate-cache
  2692. (list (cons predicate func))))
  2693. func)))
  2694. (defun gnus-predicate-implies-unread (predicate)
  2695. "Say whether PREDICATE implies unread articles only.
  2696. It is okay to miss some cases, but there must be no false positives.
  2697. That is, if this predicate returns true, then indeed the predicate must
  2698. return only unread articles."
  2699. (eq t (gnus-function-implies-unread-1
  2700. (gnus-category-make-function-1 predicate))))
  2701. (defun gnus-function-implies-unread-1 (function)
  2702. "Recursively evaluate a predicate function to determine whether it can select
  2703. any read articles. Returns t if the function is known to never
  2704. return read articles, nil when it is known to always return read
  2705. articles, and t_nil when the function may return both read and unread
  2706. articles."
  2707. (let ((func (car function))
  2708. (args (mapcar 'gnus-function-implies-unread-1 (cdr function))))
  2709. (cond ((eq func 'and)
  2710. (cond ((memq t args) ; if any argument returns only unread articles
  2711. ;; then that argument constrains the result to only unread articles.
  2712. t)
  2713. ((memq 't_nil args) ; if any argument is indeterminate
  2714. ;; then the result is indeterminate
  2715. 't_nil)))
  2716. ((eq func 'or)
  2717. (cond ((memq nil args) ; if any argument returns read articles
  2718. ;; then that argument ensures that the results includes read articles.
  2719. nil)
  2720. ((memq 't_nil args) ; if any argument is indeterminate
  2721. ;; then that argument ensures that the results are indeterminate
  2722. 't_nil)
  2723. (t ; if all arguments return only unread articles
  2724. ;; then the result returns only unread articles
  2725. t)))
  2726. ((eq func 'not)
  2727. (cond ((eq (car args) 't_nil) ; if the argument is indeterminate
  2728. ; then the result is indeterminate
  2729. (car args))
  2730. (t ; otherwise
  2731. ; toggle the result to be the opposite of the argument
  2732. (not (car args)))))
  2733. ((eq func 'gnus-agent-read-p)
  2734. nil) ; The read predicate NEVER returns unread articles
  2735. ((eq func 'gnus-agent-false)
  2736. t) ; The false predicate returns t as the empty set excludes all read articles
  2737. ((eq func 'gnus-agent-true)
  2738. nil) ; The true predicate ALWAYS returns read articles
  2739. ((catch 'found-match
  2740. (let ((alist gnus-category-predicate-alist))
  2741. (while alist
  2742. (if (eq func (cdar alist))
  2743. (throw 'found-match t)
  2744. (setq alist (cdr alist))))))
  2745. 't_nil) ; All other predicates return read and unread articles
  2746. (t
  2747. (error "Unknown predicate function: %s" function)))))
  2748. (defun gnus-group-category (group)
  2749. "Return the category GROUP belongs to."
  2750. (unless gnus-category-group-cache
  2751. (setq gnus-category-group-cache (gnus-make-hashtable 1000))
  2752. (let ((cs gnus-category-alist)
  2753. groups cat)
  2754. (while (setq cat (pop cs))
  2755. (setq groups (gnus-agent-cat-groups cat))
  2756. (while groups
  2757. (gnus-sethash (pop groups) cat gnus-category-group-cache)))))
  2758. (or (gnus-gethash group gnus-category-group-cache)
  2759. (assq 'default gnus-category-alist)))
  2760. (defun gnus-agent-expire-group (group &optional articles force)
  2761. "Expire all old articles in GROUP.
  2762. If you want to force expiring of certain articles, this function can
  2763. take ARTICLES, and FORCE parameters as well.
  2764. The articles on which the expiration process runs are selected as follows:
  2765. if ARTICLES is null, all read and unmarked articles.
  2766. if ARTICLES is t, all articles.
  2767. if ARTICLES is a list, just those articles.
  2768. FORCE is equivalent to setting the expiration predicates to true."
  2769. (interactive (list (gnus-agent-read-group)))
  2770. (if (not group)
  2771. (gnus-agent-expire articles group force)
  2772. (let ( ;; Bind gnus-agent-expire-stats to enable tracking of
  2773. ;; expiration statistics of this single group
  2774. (gnus-agent-expire-stats (list 0 0 0.0)))
  2775. (if (or (not (eq articles t))
  2776. (yes-or-no-p
  2777. (concat "Are you sure that you want to "
  2778. "expire all articles in " group "? ")))
  2779. (let ((gnus-command-method (gnus-find-method-for-group group))
  2780. (overview (gnus-get-buffer-create " *expire overview*"))
  2781. orig)
  2782. (unwind-protect
  2783. (let ((active-file (gnus-agent-lib-file "active")))
  2784. (when (file-exists-p active-file)
  2785. (with-temp-buffer
  2786. (nnheader-insert-file-contents active-file)
  2787. (gnus-active-to-gnus-format
  2788. gnus-command-method
  2789. (setq orig (gnus-make-hashtable
  2790. (count-lines (point-min) (point-max))))))
  2791. (save-excursion
  2792. (gnus-agent-expire-group-1
  2793. group overview (gnus-gethash-safe group orig)
  2794. articles force))))
  2795. (kill-buffer overview))))
  2796. (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))
  2797. (defun gnus-agent-expire-group-1 (group overview active articles force)
  2798. ;; Internal function - requires caller to have set
  2799. ;; gnus-command-method, initialized overview buffer, and to have
  2800. ;; provided a non-nil active
  2801. (let ((dir (gnus-agent-group-pathname group))
  2802. (file-name-coding-system nnmail-pathname-coding-system)
  2803. (decoded (gnus-agent-decoded-group-name group)))
  2804. (gnus-agent-with-refreshed-group
  2805. group
  2806. (when (boundp 'gnus-agent-expire-current-dirs)
  2807. (set 'gnus-agent-expire-current-dirs
  2808. (cons dir
  2809. (symbol-value 'gnus-agent-expire-current-dirs))))
  2810. (if (and (not force)
  2811. (eq 'DISABLE (gnus-agent-find-parameter group
  2812. 'agent-enable-expiration)))
  2813. (gnus-message 5 "Expiry skipping over %s" decoded)
  2814. (gnus-message 5 "Expiring articles in %s" decoded)
  2815. (gnus-agent-load-alist group)
  2816. (let* ((bytes-freed 0)
  2817. (size-files-deleted 0.0)
  2818. (files-deleted 0)
  2819. (nov-entries-deleted 0)
  2820. (info (gnus-get-info group))
  2821. (alist gnus-agent-article-alist)
  2822. (day (- (time-to-days (current-time))
  2823. (gnus-agent-find-parameter group 'agent-days-until-old)))
  2824. (specials (if (and alist
  2825. (not force))
  2826. ;; This could be a bit of a problem. I need to
  2827. ;; keep the last article to avoid refetching
  2828. ;; headers when using nntp in the backend. At
  2829. ;; the same time, if someone uses a backend
  2830. ;; that supports article moving then I may have
  2831. ;; to remove the last article to complete the
  2832. ;; move. Right now, I'm going to assume that
  2833. ;; FORCE overrides specials.
  2834. (list (caar (last alist)))))
  2835. (unreads ;; Articles that are excluded from the
  2836. ;; expiration process
  2837. (cond (gnus-agent-expire-all
  2838. ;; All articles are marked read by global decree
  2839. nil)
  2840. ((eq articles t)
  2841. ;; All articles are marked read by function
  2842. ;; parameter
  2843. nil)
  2844. ((not articles)
  2845. ;; Unread articles are marked protected from
  2846. ;; expiration Don't call
  2847. ;; gnus-list-of-unread-articles as it returns
  2848. ;; articles that have not been fetched into the
  2849. ;; agent.
  2850. (ignore-errors
  2851. (gnus-agent-unread-articles group)))
  2852. (t
  2853. ;; All articles EXCEPT those named by the caller
  2854. ;; are protected from expiration
  2855. (gnus-sorted-difference
  2856. (gnus-uncompress-range
  2857. (cons (caar alist)
  2858. (caar (last alist))))
  2859. (sort articles '<)))))
  2860. (marked ;; More articles that are excluded from the
  2861. ;; expiration process
  2862. (cond (gnus-agent-expire-all
  2863. ;; All articles are unmarked by global decree
  2864. nil)
  2865. ((eq articles t)
  2866. ;; All articles are unmarked by function
  2867. ;; parameter
  2868. nil)
  2869. (articles
  2870. ;; All articles may as well be unmarked as the
  2871. ;; unreads list already names the articles we are
  2872. ;; going to keep
  2873. nil)
  2874. (t
  2875. ;; Ticked and/or dormant articles are excluded
  2876. ;; from expiration
  2877. (nconc
  2878. (gnus-uncompress-range
  2879. (cdr (assq 'tick (gnus-info-marks info))))
  2880. (gnus-uncompress-range
  2881. (cdr (assq 'dormant
  2882. (gnus-info-marks info))))))))
  2883. (nov-file (concat dir ".overview"))
  2884. (cnt 0)
  2885. (completed -1)
  2886. dlist
  2887. type)
  2888. ;; The normal article alist contains elements that look like
  2889. ;; (article# . fetch_date) I need to combine other
  2890. ;; information with this list. For example, a flag indicating
  2891. ;; that a particular article MUST BE KEPT. To do this, I'm
  2892. ;; going to transform the elements to look like (article#
  2893. ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse
  2894. ;; the process to generate the expired article alist.
  2895. ;; Convert the alist elements to (article# fetch_date nil
  2896. ;; nil).
  2897. (setq dlist (mapcar (lambda (e)
  2898. (list (car e) (cdr e) nil nil)) alist))
  2899. ;; Convert the keep lists to elements that look like (article#
  2900. ;; nil keep_flag nil) then append it to the expanded dlist
  2901. ;; These statements are sorted by ascending precedence of the
  2902. ;; keep_flag.
  2903. (setq dlist (nconc dlist
  2904. (mapcar (lambda (e)
  2905. (list e nil 'unread nil))
  2906. unreads)))
  2907. (setq dlist (nconc dlist
  2908. (mapcar (lambda (e)
  2909. (list e nil 'marked nil))
  2910. marked)))
  2911. (setq dlist (nconc dlist
  2912. (mapcar (lambda (e)
  2913. (list e nil 'special nil))
  2914. specials)))
  2915. (set-buffer overview)
  2916. (erase-buffer)
  2917. (buffer-disable-undo)
  2918. (when (file-exists-p nov-file)
  2919. (gnus-message 7 "gnus-agent-expire: Loading overview...")
  2920. (nnheader-insert-file-contents nov-file)
  2921. (goto-char (point-min))
  2922. (let (p)
  2923. (while (< (setq p (point)) (point-max))
  2924. (condition-case nil
  2925. ;; If I successfully read an integer (the plus zero
  2926. ;; ensures a numeric type), append the position
  2927. ;; to the list
  2928. (push (list (+ 0 (read (current-buffer))) nil nil
  2929. p)
  2930. dlist)
  2931. (error
  2932. (gnus-message 1 "gnus-agent-expire: read error \
  2933. occurred when reading expression at %s in %s. Skipping to next \
  2934. line." (point) nov-file)))
  2935. ;; Whether I succeeded, or failed, it doesn't matter.
  2936. ;; Move to the next line then try again.
  2937. (forward-line 1)))
  2938. (gnus-message
  2939. 7 "gnus-agent-expire: Loading overview... Done"))
  2940. (set-buffer-modified-p nil)
  2941. ;; At this point, all of the information is in dlist. The
  2942. ;; only problem is that much of it is spread across multiple
  2943. ;; entries. Sort then MERGE!!
  2944. (gnus-message 7 "gnus-agent-expire: Sorting entries... ")
  2945. ;; If two entries have the same article-number then sort by
  2946. ;; ascending keep_flag.
  2947. (let ((special 0)
  2948. (marked 1)
  2949. (unread 2))
  2950. (setq dlist
  2951. (sort dlist
  2952. (lambda (a b)
  2953. (cond ((< (nth 0 a) (nth 0 b))
  2954. t)
  2955. ((> (nth 0 a) (nth 0 b))
  2956. nil)
  2957. (t
  2958. (let ((a (or (symbol-value (nth 2 a))
  2959. 3))
  2960. (b (or (symbol-value (nth 2 b))
  2961. 3)))
  2962. (<= a b))))))))
  2963. (gnus-message 7 "gnus-agent-expire: Sorting entries... Done")
  2964. (gnus-message 7 "gnus-agent-expire: Merging entries... ")
  2965. (let ((dlist dlist))
  2966. (while (cdr dlist) ; I'm not at the end-of-list
  2967. (if (eq (caar dlist) (caadr dlist))
  2968. (let ((first (cdr (car dlist)))
  2969. (secnd (cdr (cadr dlist))))
  2970. (setcar first (or (car first)
  2971. (car secnd))) ; fetch_date
  2972. (setq first (cdr first)
  2973. secnd (cdr secnd))
  2974. (setcar first (or (car first)
  2975. (car secnd))) ; Keep_flag
  2976. (setq first (cdr first)
  2977. secnd (cdr secnd))
  2978. (setcar first (or (car first)
  2979. (car secnd))) ; NOV_entry_position
  2980. (setcdr dlist (cddr dlist)))
  2981. (setq dlist (cdr dlist)))))
  2982. ;; Check the order of the entry positions. They should be in
  2983. ;; ascending order. If they aren't, the positions must be
  2984. ;; converted to markers.
  2985. (when (catch 'sort-results
  2986. (let ((dlist dlist)
  2987. (prev-pos -1)
  2988. pos)
  2989. (while dlist
  2990. (if (setq pos (nth 3 (pop dlist)))
  2991. (if (< pos prev-pos)
  2992. (throw 'sort-results 'unsorted)
  2993. (setq prev-pos pos))))))
  2994. (gnus-message 7 "gnus-agent-expire: Unsorted overview; inserting markers to compensate.")
  2995. (mapc (lambda (entry)
  2996. (let ((pos (nth 3 entry)))
  2997. (if pos
  2998. (setf (nth 3 entry)
  2999. (set-marker (make-marker)
  3000. pos)))))
  3001. dlist))
  3002. (gnus-message 7 "gnus-agent-expire: Merging entries... Done")
  3003. (let* ((len (float (length dlist)))
  3004. (alist (list nil))
  3005. (tail-alist alist)
  3006. (position-offset 0)
  3007. )
  3008. (while dlist
  3009. (let ((new-completed (truncate (* 100.0
  3010. (/ (setq cnt (1+ cnt))
  3011. len))))
  3012. message-log-max)
  3013. (when (> new-completed completed)
  3014. (setq completed new-completed)
  3015. (gnus-message 7 "%3d%% completed..." completed)))
  3016. (let* ((entry (car dlist))
  3017. (article-number (nth 0 entry))
  3018. (fetch-date (nth 1 entry))
  3019. (keep (nth 2 entry))
  3020. (marker (nth 3 entry)))
  3021. (cond
  3022. ;; Kept articles are unread, marked, or special.
  3023. (keep
  3024. (gnus-agent-message 10
  3025. "gnus-agent-expire: %s:%d: Kept %s article%s."
  3026. decoded article-number keep (if fetch-date " and file" ""))
  3027. (when fetch-date
  3028. (unless (file-exists-p
  3029. (concat dir (number-to-string
  3030. article-number)))
  3031. (setf (nth 1 entry) nil)
  3032. (gnus-agent-message 3 "gnus-agent-expire cleared \
  3033. download flag on %s:%d as the cached article file is missing."
  3034. decoded (caar dlist)))
  3035. (unless marker
  3036. (gnus-message 1 "gnus-agent-expire detected a \
  3037. missing NOV entry. Run gnus-agent-regenerate-group to restore it.")))
  3038. (gnus-agent-append-to-list
  3039. tail-alist
  3040. (cons article-number fetch-date)))
  3041. ;; The following articles are READ, UNMARKED, and
  3042. ;; ORDINARY. See if they can be EXPIRED!!!
  3043. ((setq type
  3044. (cond
  3045. ((not (integerp fetch-date))
  3046. 'read) ;; never fetched article (may expire
  3047. ;; right now)
  3048. ((not (file-exists-p
  3049. (concat dir (number-to-string
  3050. article-number))))
  3051. (setf (nth 1 entry) nil)
  3052. 'externally-expired) ;; Can't find the cached
  3053. ;; article. Handle case
  3054. ;; as though this article
  3055. ;; was never fetched.
  3056. ;; We now have the arrival day, so we see
  3057. ;; whether it's old enough to be expired.
  3058. ((< fetch-date day)
  3059. 'expired)
  3060. (force
  3061. 'forced)))
  3062. ;; I found some reason to expire this entry.
  3063. (let ((actions nil))
  3064. (when (memq type '(forced expired))
  3065. (ignore-errors ; Just being paranoid.
  3066. (let* ((file-name (nnheader-concat dir (number-to-string
  3067. article-number)))
  3068. (size (float (nth 7 (file-attributes file-name)))))
  3069. (incf bytes-freed size)
  3070. (incf size-files-deleted size)
  3071. (incf files-deleted)
  3072. (delete-file file-name))
  3073. (push "expired cached article" actions))
  3074. (setf (nth 1 entry) nil)
  3075. )
  3076. (when marker
  3077. (push "NOV entry removed" actions)
  3078. (goto-char (if (markerp marker)
  3079. marker
  3080. (- marker position-offset)))
  3081. (incf nov-entries-deleted)
  3082. (let* ((from (point-at-bol))
  3083. (to (progn (forward-line 1) (point)))
  3084. (freed (- to from)))
  3085. (incf bytes-freed freed)
  3086. (incf position-offset freed)
  3087. (delete-region from to)))
  3088. ;; If considering all articles is set, I can only
  3089. ;; expire article IDs that are no longer in the
  3090. ;; active range (That is, articles that precede the
  3091. ;; first article in the new alist).
  3092. (if (and gnus-agent-consider-all-articles
  3093. (>= article-number (car active)))
  3094. ;; I have to keep this ID in the alist
  3095. (gnus-agent-append-to-list
  3096. tail-alist (cons article-number fetch-date))
  3097. (push (format "Removed %s article number from \
  3098. article alist" type) actions))
  3099. (when actions
  3100. (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s"
  3101. decoded article-number
  3102. (mapconcat 'identity actions ", ")))))
  3103. (t
  3104. (gnus-agent-message
  3105. 10 "gnus-agent-expire: %s:%d: Article kept as \
  3106. expiration tests failed." decoded article-number)
  3107. (gnus-agent-append-to-list
  3108. tail-alist (cons article-number fetch-date)))
  3109. )
  3110. ;; Remove markers as I intend to reuse this buffer again.
  3111. (when (and marker
  3112. (markerp marker))
  3113. (set-marker marker nil))
  3114. (setq dlist (cdr dlist))))
  3115. (setq alist (cdr alist))
  3116. (let ((inhibit-quit t))
  3117. (unless (equal alist gnus-agent-article-alist)
  3118. (setq gnus-agent-article-alist alist)
  3119. (gnus-agent-save-alist group))
  3120. (when (buffer-modified-p)
  3121. (let ((coding-system-for-write
  3122. gnus-agent-file-coding-system))
  3123. (gnus-make-directory dir)
  3124. (write-region (point-min) (point-max) nov-file nil
  3125. 'silent)
  3126. ;; clear the modified flag as that I'm not confused by
  3127. ;; its status on the next pass through this routine.
  3128. (set-buffer-modified-p nil)
  3129. (gnus-agent-update-view-total-fetched-for group t)))
  3130. (when (eq articles t)
  3131. (gnus-summary-update-info))))
  3132. (when (boundp 'gnus-agent-expire-stats)
  3133. (let ((stats (symbol-value 'gnus-agent-expire-stats)))
  3134. (incf (nth 2 stats) bytes-freed)
  3135. (incf (nth 1 stats) files-deleted)
  3136. (incf (nth 0 stats) nov-entries-deleted)))
  3137. (gnus-agent-update-files-total-fetched-for group (- size-files-deleted)))))))
  3138. (defun gnus-agent-expire (&optional articles group force)
  3139. "Expire all old articles.
  3140. If you want to force expiring of certain articles, this function can
  3141. take ARTICLES, GROUP and FORCE parameters as well.
  3142. The articles on which the expiration process runs are selected as follows:
  3143. if ARTICLES is null, all read and unmarked articles.
  3144. if ARTICLES is t, all articles.
  3145. if ARTICLES is a list, just those articles.
  3146. Setting GROUP will limit expiration to that group.
  3147. FORCE is equivalent to setting the expiration predicates to true."
  3148. (interactive)
  3149. (if group
  3150. (gnus-agent-expire-group group articles force)
  3151. (if (or (not (eq articles t))
  3152. (yes-or-no-p "Are you sure that you want to expire all \
  3153. articles in every agentized group? "))
  3154. (let ((methods (gnus-agent-covered-methods))
  3155. ;; Bind gnus-agent-expire-current-dirs to enable tracking
  3156. ;; of agent directories.
  3157. (gnus-agent-expire-current-dirs nil)
  3158. ;; Bind gnus-agent-expire-stats to enable tracking of
  3159. ;; expiration statistics across all groups
  3160. (gnus-agent-expire-stats (list 0 0 0.0))
  3161. gnus-command-method overview orig)
  3162. (setq overview (gnus-get-buffer-create " *expire overview*"))
  3163. (unwind-protect
  3164. (while (setq gnus-command-method (pop methods))
  3165. (let ((active-file (gnus-agent-lib-file "active")))
  3166. (when (file-exists-p active-file)
  3167. (with-temp-buffer
  3168. (nnheader-insert-file-contents active-file)
  3169. (gnus-active-to-gnus-format
  3170. gnus-command-method
  3171. (setq orig (gnus-make-hashtable
  3172. (count-lines (point-min) (point-max))))))
  3173. (dolist (expiring-group (gnus-groups-from-server
  3174. gnus-command-method))
  3175. (let* ((active
  3176. (gnus-gethash-safe expiring-group orig)))
  3177. (when active
  3178. (save-excursion
  3179. (gnus-agent-expire-group-1
  3180. expiring-group overview active articles force))))))))
  3181. (kill-buffer overview))
  3182. (gnus-agent-expire-unagentized-dirs)
  3183. (gnus-message 4 "%s" (gnus-agent-expire-done-message))))))
  3184. (defun gnus-agent-expire-done-message ()
  3185. (if (and (> gnus-verbose 4)
  3186. (boundp 'gnus-agent-expire-stats))
  3187. (let* ((stats (symbol-value 'gnus-agent-expire-stats))
  3188. (size (nth 2 stats))
  3189. (units '(B KB MB GB)))
  3190. (while (and (> size 1024.0)
  3191. (cdr units))
  3192. (setq size (/ size 1024.0)
  3193. units (cdr units)))
  3194. (format "Expiry recovered %d NOV entries, deleted %d files,\
  3195. and freed %.f %s."
  3196. (nth 0 stats)
  3197. (nth 1 stats)
  3198. size (car units)))
  3199. "Expiry...done"))
  3200. (defun gnus-agent-expire-unagentized-dirs ()
  3201. (when (and gnus-agent-expire-unagentized-dirs
  3202. (boundp 'gnus-agent-expire-current-dirs))
  3203. (let* ((keep (gnus-make-hashtable))
  3204. ;; Formally bind gnus-agent-expire-current-dirs so that the
  3205. ;; compiler will not complain about free references.
  3206. (gnus-agent-expire-current-dirs
  3207. (symbol-value 'gnus-agent-expire-current-dirs))
  3208. dir
  3209. (file-name-coding-system nnmail-pathname-coding-system))
  3210. (gnus-sethash gnus-agent-directory t keep)
  3211. (while gnus-agent-expire-current-dirs
  3212. (setq dir (pop gnus-agent-expire-current-dirs))
  3213. (when (and (stringp dir)
  3214. (file-directory-p dir))
  3215. (while (not (gnus-gethash dir keep))
  3216. (gnus-sethash dir t keep)
  3217. (setq dir (file-name-directory (directory-file-name dir))))))
  3218. (let* (to-remove
  3219. checker
  3220. (checker
  3221. (function
  3222. (lambda (d)
  3223. "Given a directory, check it and its subdirectories for
  3224. membership in the keep hash. If it isn't found, add
  3225. it to to-remove."
  3226. (let ((files (directory-files d))
  3227. file)
  3228. (while (setq file (pop files))
  3229. (cond ((equal file ".") ; Ignore self
  3230. nil)
  3231. ((equal file "..") ; Ignore parent
  3232. nil)
  3233. ((equal file ".overview")
  3234. ;; Directory must contain .overview to be
  3235. ;; agent's cache of a group.
  3236. (let ((d (file-name-as-directory d))
  3237. r)
  3238. ;; Search ancestor's for last directory NOT
  3239. ;; found in keep hash.
  3240. (while (not (gnus-gethash
  3241. (setq d (file-name-directory d)) keep))
  3242. (setq r d
  3243. d (directory-file-name d)))
  3244. ;; if ANY ancestor was NOT in keep hash and
  3245. ;; it's not already in to-remove, add it to
  3246. ;; to-remove.
  3247. (if (and r
  3248. (not (member r to-remove)))
  3249. (push r to-remove))))
  3250. ((file-directory-p (setq file (nnheader-concat d file)))
  3251. (funcall checker file)))))))))
  3252. (funcall checker (expand-file-name gnus-agent-directory))
  3253. (when (and to-remove
  3254. (or gnus-expert-user
  3255. (gnus-y-or-n-p
  3256. "gnus-agent-expire has identified local directories that are\
  3257. not currently required by any agentized group. Do you wish to consider\
  3258. deleting them?")))
  3259. (while to-remove
  3260. (let ((dir (pop to-remove)))
  3261. (if (or gnus-expert-user
  3262. (gnus-y-or-n-p (format "Delete %s? " dir)))
  3263. (let* (delete-recursive
  3264. files f
  3265. (delete-recursive
  3266. (function
  3267. (lambda (f-or-d)
  3268. (ignore-errors
  3269. (if (file-directory-p f-or-d)
  3270. (condition-case nil
  3271. (delete-directory f-or-d)
  3272. (file-error
  3273. (setq files (directory-files f-or-d))
  3274. (while files
  3275. (setq f (pop files))
  3276. (or (member f '("." ".."))
  3277. (funcall delete-recursive
  3278. (nnheader-concat
  3279. f-or-d f))))
  3280. (delete-directory f-or-d)))
  3281. (delete-file f-or-d)))))))
  3282. (funcall delete-recursive dir))))))))))
  3283. ;;;###autoload
  3284. (defun gnus-agent-batch ()
  3285. "Start Gnus, send queue and fetch session."
  3286. (interactive)
  3287. (let ((init-file-user "")
  3288. (gnus-always-read-dribble-file t))
  3289. (gnus))
  3290. (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation))
  3291. (gnus-group-send-queue)
  3292. (gnus-agent-fetch-session)))
  3293. (defun gnus-agent-unread-articles (group)
  3294. (let* ((read (gnus-info-read (gnus-get-info group)))
  3295. (known (gnus-agent-load-alist group))
  3296. (unread (list nil))
  3297. (tail-unread unread))
  3298. (while (and known read)
  3299. (let ((candidate (car (pop known))))
  3300. (while (let* ((range (car read))
  3301. (min (if (numberp range) range (car range)))
  3302. (max (if (numberp range) range (cdr range))))
  3303. (cond ((or (not min)
  3304. (< candidate min))
  3305. (gnus-agent-append-to-list tail-unread candidate)
  3306. nil)
  3307. ((> candidate max)
  3308. (setq read (cdr read))
  3309. ;; return t so that I always loop one more
  3310. ;; time. If I just iterated off the end of
  3311. ;; read, min will become nil and the current
  3312. ;; candidate will be added to the unread list.
  3313. t))))))
  3314. (while known
  3315. (gnus-agent-append-to-list tail-unread (car (pop known))))
  3316. (cdr unread)))
  3317. (defun gnus-agent-uncached-articles (articles group &optional cached-header)
  3318. "Restrict ARTICLES to numbers already fetched.
  3319. Returns a sublist of ARTICLES that excludes those article ids in GROUP
  3320. that have already been fetched.
  3321. If CACHED-HEADER is nil, articles are only excluded if the article itself
  3322. has been fetched."
  3323. ;; Logically equivalent to: (gnus-sorted-difference articles (mapcar
  3324. ;; 'car gnus-agent-article-alist))
  3325. ;; Functionally, I don't need to construct a temp list using mapcar.
  3326. (if (and (or gnus-agent-cache (not gnus-plugged))
  3327. (gnus-agent-load-alist group))
  3328. (let* ((ref gnus-agent-article-alist)
  3329. (arts articles)
  3330. (uncached (list nil))
  3331. (tail-uncached uncached))
  3332. (while (and ref arts)
  3333. (let ((v1 (car arts))
  3334. (v2 (caar ref)))
  3335. (cond ((< v1 v2) ; v1 does not appear in the reference list
  3336. (gnus-agent-append-to-list tail-uncached v1)
  3337. (setq arts (cdr arts)))
  3338. ((= v1 v2)
  3339. (unless (or cached-header (cdar ref)) ; v1 is already cached
  3340. (gnus-agent-append-to-list tail-uncached v1))
  3341. (setq arts (cdr arts))
  3342. (setq ref (cdr ref)))
  3343. (t ; reference article (v2) precedes the list being filtered
  3344. (setq ref (cdr ref))))))
  3345. (while arts
  3346. (gnus-agent-append-to-list tail-uncached (pop arts)))
  3347. (cdr uncached))
  3348. ;; if gnus-agent-load-alist fails, no articles are cached.
  3349. articles))
  3350. (defun gnus-agent-retrieve-headers (articles group &optional fetch-old)
  3351. (save-excursion
  3352. (gnus-agent-create-buffer)
  3353. (let ((gnus-decode-encoded-word-function 'identity)
  3354. (gnus-decode-encoded-address-function 'identity)
  3355. (file (gnus-agent-article-name ".overview" group))
  3356. cached-articles uncached-articles
  3357. (file-name-coding-system nnmail-pathname-coding-system))
  3358. (gnus-make-directory (nnheader-translate-file-chars
  3359. (file-name-directory file) t))
  3360. ;; Populate temp buffer with known headers
  3361. (when (file-exists-p file)
  3362. (with-current-buffer gnus-agent-overview-buffer
  3363. (erase-buffer)
  3364. (let ((nnheader-file-coding-system
  3365. gnus-agent-file-coding-system))
  3366. (nnheader-insert-nov-file file (car articles)))))
  3367. (if (setq uncached-articles (gnus-agent-uncached-articles articles group
  3368. t))
  3369. (progn
  3370. ;; Populate nntp-server-buffer with uncached headers
  3371. (set-buffer nntp-server-buffer)
  3372. (erase-buffer)
  3373. (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent
  3374. (gnus-retrieve-headers
  3375. uncached-articles group))))
  3376. (nnvirtual-convert-headers))
  3377. ((eq 'nntp (car gnus-current-select-method))
  3378. ;; The author of gnus-get-newsgroup-headers-xover
  3379. ;; reports that the XOVER command is commonly
  3380. ;; unreliable. The problem is that recently
  3381. ;; posted articles may not be entered into the
  3382. ;; NOV database in time to respond to my XOVER
  3383. ;; query.
  3384. ;;
  3385. ;; I'm going to use his assumption that the NOV
  3386. ;; database is updated in order of ascending
  3387. ;; article ID. Therefore, a response containing
  3388. ;; article ID N implies that all articles from 1
  3389. ;; to N-1 are up-to-date. Therefore, missing
  3390. ;; articles in that range have expired.
  3391. (set-buffer nntp-server-buffer)
  3392. (let* ((fetched-articles (list nil))
  3393. (tail-fetched-articles fetched-articles)
  3394. (min (cond ((numberp fetch-old)
  3395. (max 1 (- (car articles) fetch-old)))
  3396. (fetch-old
  3397. 1)
  3398. (t
  3399. (car articles))))
  3400. (max (car (last articles))))
  3401. ;; Get the list of articles that were fetched
  3402. (goto-char (point-min))
  3403. (let ((pm (point-max))
  3404. art)
  3405. (while (< (point) pm)
  3406. (when (setq art (gnus-agent-read-article-number))
  3407. (gnus-agent-append-to-list tail-fetched-articles art))
  3408. (forward-line 1)))
  3409. ;; Clip this list to the headers that will
  3410. ;; actually be returned
  3411. (setq fetched-articles (gnus-list-range-intersection
  3412. (cdr fetched-articles)
  3413. (cons min max)))
  3414. ;; Clip the uncached articles list to exclude
  3415. ;; IDs after the last FETCHED header. The
  3416. ;; excluded IDs may be fetchable using HEAD.
  3417. (if (car tail-fetched-articles)
  3418. (setq uncached-articles
  3419. (gnus-list-range-intersection
  3420. uncached-articles
  3421. (cons (car uncached-articles)
  3422. (car tail-fetched-articles)))))
  3423. ;; Create the list of articles that were
  3424. ;; "successfully" fetched. Success, in this
  3425. ;; case, means that the ID should not be
  3426. ;; fetched again. In the case of an expired
  3427. ;; article, the header will not be fetched.
  3428. (setq uncached-articles
  3429. (gnus-sorted-nunion fetched-articles
  3430. uncached-articles))
  3431. )))
  3432. ;; Erase the temp buffer
  3433. (set-buffer gnus-agent-overview-buffer)
  3434. (erase-buffer)
  3435. ;; Copy the nntp-server-buffer to the temp buffer
  3436. (set-buffer nntp-server-buffer)
  3437. (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max))
  3438. ;; Merge the temp buffer with the known headers (found on
  3439. ;; disk in FILE) into the nntp-server-buffer
  3440. (when uncached-articles
  3441. (gnus-agent-braid-nov group uncached-articles file))
  3442. ;; Save the new set of known headers to FILE
  3443. (set-buffer nntp-server-buffer)
  3444. (let ((coding-system-for-write
  3445. gnus-agent-file-coding-system))
  3446. (gnus-agent-check-overview-buffer)
  3447. (write-region (point-min) (point-max) file nil 'silent))
  3448. (gnus-agent-update-view-total-fetched-for group t)
  3449. ;; Update the group's article alist to include the newly
  3450. ;; fetched articles.
  3451. (gnus-agent-load-alist group)
  3452. (gnus-agent-save-alist group uncached-articles nil)
  3453. )
  3454. ;; Copy the temp buffer to the nntp-server-buffer
  3455. (set-buffer nntp-server-buffer)
  3456. (erase-buffer)
  3457. (insert-buffer-substring gnus-agent-overview-buffer)))
  3458. (if (and fetch-old
  3459. (not (numberp fetch-old)))
  3460. t ; Don't remove anything.
  3461. (nnheader-nov-delete-outside-range
  3462. (if fetch-old (max 1 (- (car articles) fetch-old))
  3463. (car articles))
  3464. (car (last articles)))
  3465. t)
  3466. 'nov))
  3467. (defun gnus-agent-request-article (article group)
  3468. "Retrieve ARTICLE in GROUP from the agent cache."
  3469. (when (and gnus-agent
  3470. (or gnus-agent-cache
  3471. (not gnus-plugged))
  3472. (numberp article))
  3473. (let* ((gnus-command-method (gnus-find-method-for-group group))
  3474. (file (gnus-agent-article-name (number-to-string article) group))
  3475. (buffer-read-only nil)
  3476. (file-name-coding-system nnmail-pathname-coding-system))
  3477. (when (and (file-exists-p file)
  3478. (> (nth 7 (file-attributes file)) 0))
  3479. (erase-buffer)
  3480. (gnus-kill-all-overlays)
  3481. (let ((coding-system-for-read gnus-cache-coding-system))
  3482. (insert-file-contents file))
  3483. t))))
  3484. (defun gnus-agent-store-article (article group)
  3485. (let* ((gnus-command-method (gnus-find-method-for-group group))
  3486. (file (gnus-agent-article-name (number-to-string article) group))
  3487. (file-name-coding-system nnmail-pathname-coding-system)
  3488. (coding-system-for-write gnus-cache-coding-system))
  3489. (when (not (file-exists-p file))
  3490. (gnus-make-directory (file-name-directory file))
  3491. (write-region (point-min) (point-max) file nil 'silent)
  3492. ;; Tell the Agent when the article was fetched, so that it can
  3493. ;; be expired later.
  3494. (gnus-agent-load-alist group)
  3495. (gnus-agent-save-alist group (list article)
  3496. (time-to-days (current-time))))))
  3497. (defun gnus-agent-regenerate-group (group &optional reread)
  3498. "Regenerate GROUP.
  3499. If REREAD is t, all articles in the .overview are marked as unread.
  3500. If REREAD is a list, the specified articles will be marked as unread.
  3501. In addition, their NOV entries in .overview will be refreshed using
  3502. the articles' current headers.
  3503. If REREAD is not nil, downloaded articles are marked as unread."
  3504. (interactive
  3505. (list (gnus-agent-read-group)
  3506. (catch 'mark
  3507. (while (let (c
  3508. (cursor-in-echo-area t)
  3509. (echo-keystrokes 0))
  3510. (message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ")
  3511. (setq c (read-char-exclusive))
  3512. (cond ((or (eq c ?\r) (eq c ?n) (eq c ?N))
  3513. (throw 'mark nil))
  3514. ((or (eq c ?a) (eq c ?A))
  3515. (throw 'mark t))
  3516. ((or (eq c ?d) (eq c ?D))
  3517. (throw 'mark 'some)))
  3518. (gnus-message 3 "Ignoring unexpected input")
  3519. (sit-for 1)
  3520. t)))))
  3521. (when group
  3522. (gnus-message 5 "Regenerating in %s" (gnus-agent-decoded-group-name group))
  3523. (let* ((gnus-command-method (or gnus-command-method
  3524. (gnus-find-method-for-group group)))
  3525. (file (gnus-agent-article-name ".overview" group))
  3526. (dir (file-name-directory file))
  3527. point
  3528. (file-name-coding-system nnmail-pathname-coding-system)
  3529. (downloaded (if (file-exists-p dir)
  3530. (sort (delq nil (mapcar (lambda (name)
  3531. (and (not (file-directory-p (nnheader-concat dir name)))
  3532. (string-to-number name)))
  3533. (directory-files dir nil "^[0-9]+$" t)))
  3534. '>)
  3535. (progn (gnus-make-directory dir) nil)))
  3536. dl nov-arts
  3537. alist header
  3538. regenerated)
  3539. (mm-with-unibyte-buffer
  3540. (if (file-exists-p file)
  3541. (let ((nnheader-file-coding-system
  3542. gnus-agent-file-coding-system))
  3543. (nnheader-insert-file-contents file)))
  3544. (set-buffer-modified-p nil)
  3545. ;; Load the article IDs found in the overview file. As a
  3546. ;; side-effect, validate the file contents.
  3547. (let ((load t))
  3548. (while load
  3549. (setq load nil)
  3550. (goto-char (point-min))
  3551. (while (< (point) (point-max))
  3552. (cond ((and (looking-at "[0-9]+\t")
  3553. (<= (- (match-end 0) (match-beginning 0)) 9))
  3554. (push (read (current-buffer)) nov-arts)
  3555. (forward-line 1)
  3556. (let ((l1 (car nov-arts))
  3557. (l2 (cadr nov-arts)))
  3558. (cond ((and (listp reread) (memq l1 reread))
  3559. (gnus-delete-line)
  3560. (setq nov-arts (cdr nov-arts))
  3561. (gnus-message 4 "gnus-agent-regenerate-group: NOV\
  3562. entry of article %s deleted." l1))
  3563. ((not l2)
  3564. nil)
  3565. ((< l1 l2)
  3566. (gnus-message 3 "gnus-agent-regenerate-group: NOV\
  3567. entries are NOT in ascending order.")
  3568. ;; Don't sort now as I haven't verified
  3569. ;; that every line begins with a number
  3570. (setq load t))
  3571. ((= l1 l2)
  3572. (forward-line -1)
  3573. (gnus-message 4 "gnus-agent-regenerate-group: NOV\
  3574. entries contained duplicate of article %s. Duplicate deleted." l1)
  3575. (gnus-delete-line)
  3576. (setq nov-arts (cdr nov-arts))))))
  3577. (t
  3578. (gnus-message 1 "gnus-agent-regenerate-group: NOV\
  3579. entries contained line that did not begin with an article number. Deleted\
  3580. line.")
  3581. (gnus-delete-line))))
  3582. (when load
  3583. (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\
  3584. entries into ascending order.")
  3585. (sort-numeric-fields 1 (point-min) (point-max))
  3586. (setq nov-arts nil))))
  3587. (gnus-agent-check-overview-buffer)
  3588. ;; Construct a new article alist whose nodes match every header
  3589. ;; in the .overview file. As a side-effect, missing headers are
  3590. ;; reconstructed from the downloaded article file.
  3591. (while (or downloaded nov-arts)
  3592. (cond ((and downloaded
  3593. (or (not nov-arts)
  3594. (> (car downloaded) (car nov-arts))))
  3595. ;; This entry is missing from the overview file
  3596. (gnus-message 3 "Regenerating NOV %s %d..."
  3597. (gnus-agent-decoded-group-name group)
  3598. (car downloaded))
  3599. (let ((file (concat dir (number-to-string (car downloaded)))))
  3600. (mm-with-unibyte-buffer
  3601. (nnheader-insert-file-contents file)
  3602. (nnheader-remove-body)
  3603. (setq header (nnheader-parse-naked-head)))
  3604. (mail-header-set-number header (car downloaded))
  3605. (if nov-arts
  3606. (let ((key (concat "^" (int-to-string (car nov-arts))
  3607. "\t")))
  3608. (or (re-search-backward key nil t)
  3609. (re-search-forward key))
  3610. (forward-line 1))
  3611. (goto-char (point-min)))
  3612. (nnheader-insert-nov header))
  3613. (setq nov-arts (cons (car downloaded) nov-arts)))
  3614. ((eq (car downloaded) (car nov-arts))
  3615. ;; This entry in the overview has been downloaded
  3616. (push (cons (car downloaded)
  3617. (time-to-days
  3618. (nth 5 (file-attributes
  3619. (concat dir (number-to-string
  3620. (car downloaded))))))) alist)
  3621. (setq downloaded (cdr downloaded))
  3622. (setq nov-arts (cdr nov-arts)))
  3623. (t
  3624. ;; This entry in the overview has not been downloaded
  3625. (push (cons (car nov-arts) nil) alist)
  3626. (setq nov-arts (cdr nov-arts)))))
  3627. ;; When gnus-agent-consider-all-articles is set,
  3628. ;; gnus-agent-regenerate-group should NOT remove article IDs from
  3629. ;; the alist. Those IDs serve as markers to indicate that an
  3630. ;; attempt has been made to fetch that article's header.
  3631. ;; When gnus-agent-consider-all-articles is NOT set,
  3632. ;; gnus-agent-regenerate-group can remove the article ID of every
  3633. ;; article (with the exception of the last ID in the list - it's
  3634. ;; special) that no longer appears in the overview. In this
  3635. ;; situation, the last article ID in the list implies that it,
  3636. ;; and every article ID preceding it, have been fetched from the
  3637. ;; server.
  3638. (if gnus-agent-consider-all-articles
  3639. ;; Restore all article IDs that were not found in the overview file.
  3640. (let* ((n (cons nil alist))
  3641. (merged n)
  3642. (o (gnus-agent-load-alist group)))
  3643. (while o
  3644. (let ((nID (caadr n))
  3645. (oID (caar o)))
  3646. (cond ((not nID)
  3647. (setq n (setcdr n (list (list oID))))
  3648. (setq o (cdr o)))
  3649. ((< oID nID)
  3650. (setcdr n (cons (list oID) (cdr n)))
  3651. (setq o (cdr o)))
  3652. ((= oID nID)
  3653. (setq o (cdr o))
  3654. (setq n (cdr n)))
  3655. (t
  3656. (setq n (cdr n))))))
  3657. (setq alist (cdr merged)))
  3658. ;; Restore the last article ID if it is not already in the new alist
  3659. (let ((n (last alist))
  3660. (o (last (gnus-agent-load-alist group))))
  3661. (cond ((not o)
  3662. nil)
  3663. ((not n)
  3664. (push (cons (caar o) nil) alist))
  3665. ((< (caar n) (caar o))
  3666. (setcdr n (list (car o)))))))
  3667. (let ((inhibit-quit t))
  3668. (if (setq regenerated (buffer-modified-p))
  3669. (let ((coding-system-for-write gnus-agent-file-coding-system))
  3670. (write-region (point-min) (point-max) file nil 'silent)))
  3671. (setq regenerated (or regenerated
  3672. (and reread gnus-agent-article-alist)
  3673. (not (equal alist gnus-agent-article-alist))))
  3674. (setq gnus-agent-article-alist alist)
  3675. (when regenerated
  3676. (gnus-agent-save-alist group)
  3677. ;; I have to alter the group's active range NOW as
  3678. ;; gnus-make-ascending-articles-unread will use it to
  3679. ;; recalculate the number of unread articles in the group
  3680. (let ((group (gnus-group-real-name group))
  3681. (group-active (or (gnus-active group)
  3682. (gnus-activate-group group))))
  3683. (gnus-agent-possibly-alter-active group group-active)))))
  3684. (when (and reread gnus-agent-article-alist)
  3685. (gnus-agent-synchronize-group-flags
  3686. group
  3687. (list (list
  3688. (if (listp reread)
  3689. reread
  3690. (delq nil (mapcar (function (lambda (c)
  3691. (cond ((eq reread t)
  3692. (car c))
  3693. ((cdr c)
  3694. (car c)))))
  3695. gnus-agent-article-alist)))
  3696. 'del '(read)))
  3697. gnus-command-method)
  3698. (when regenerated
  3699. (gnus-agent-update-files-total-fetched-for group nil)))
  3700. (gnus-message 5 "")
  3701. regenerated)))
  3702. ;;;###autoload
  3703. (defun gnus-agent-regenerate (&optional clean reread)
  3704. "Regenerate all agent covered files.
  3705. If CLEAN, obsolete (ignore)."
  3706. (interactive "P")
  3707. (let (regenerated)
  3708. (gnus-message 4 "Regenerating Gnus agent files...")
  3709. (dolist (gnus-command-method (gnus-agent-covered-methods))
  3710. (dolist (group (gnus-groups-from-server gnus-command-method))
  3711. (setq regenerated (or (gnus-agent-regenerate-group group reread)
  3712. regenerated))))
  3713. (gnus-message 4 "Regenerating Gnus agent files...done")
  3714. regenerated))
  3715. (defun gnus-agent-go-online (&optional force)
  3716. "Switch servers into online status."
  3717. (interactive (list t))
  3718. (dolist (server gnus-opened-servers)
  3719. (when (eq (nth 1 server) 'offline)
  3720. (if (if (eq force 'ask)
  3721. (gnus-y-or-n-p
  3722. (format "Switch %s:%s into online status? "
  3723. (caar server) (cadar server)))
  3724. force)
  3725. (setcar (nthcdr 1 server) 'close)))))
  3726. (defun gnus-agent-toggle-group-plugged (group)
  3727. "Toggle the status of the server of the current group."
  3728. (interactive (list (gnus-group-group-name)))
  3729. (let* ((method (gnus-find-method-for-group group))
  3730. (status (cadr (assoc method gnus-opened-servers))))
  3731. (if (eq status 'offline)
  3732. (gnus-server-set-status method 'closed)
  3733. (gnus-close-server method)
  3734. (gnus-server-set-status method 'offline))
  3735. (message "Turn %s:%s from %s to %s." (car method) (cadr method)
  3736. (if (eq status 'offline) 'offline 'online)
  3737. (if (eq status 'offline) 'online 'offline))))
  3738. (defun gnus-agent-group-covered-p (group)
  3739. (gnus-agent-method-p (gnus-group-method group)))
  3740. (defun gnus-agent-update-files-total-fetched-for
  3741. (group delta &optional method path)
  3742. "Update, or set, the total disk space used by the articles that the
  3743. agent has fetched."
  3744. (when gnus-agent-total-fetched-hashtb
  3745. (gnus-agent-with-refreshed-group
  3746. group
  3747. ;; if null, gnus-agent-group-pathname will calc method.
  3748. (let* ((gnus-command-method method)
  3749. (path (or path (gnus-agent-group-pathname group)))
  3750. (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
  3751. (gnus-sethash path (make-list 3 0)
  3752. gnus-agent-total-fetched-hashtb)))
  3753. (file-name-coding-system nnmail-pathname-coding-system))
  3754. (when (listp delta)
  3755. (if delta
  3756. (let ((sum 0.0)
  3757. file)
  3758. (while (setq file (pop delta))
  3759. (incf sum (float (or (nth 7 (file-attributes
  3760. (nnheader-concat
  3761. path
  3762. (if (numberp file)
  3763. (number-to-string file)
  3764. file)))) 0))))
  3765. (setq delta sum))
  3766. (let ((sum (- (nth 2 entry)))
  3767. (info (directory-files-and-attributes path nil "^-?[0-9]+$" t))
  3768. file)
  3769. (while (setq file (pop info))
  3770. (incf sum (float (or (nth 8 file) 0))))
  3771. (setq delta sum))))
  3772. (setq gnus-agent-need-update-total-fetched-for t)
  3773. (incf (nth 2 entry) delta)))))
  3774. (defun gnus-agent-update-view-total-fetched-for
  3775. (group agent-over &optional method path)
  3776. "Update, or set, the total disk space used by the .agentview and
  3777. .overview files. These files are calculated separately as they can be
  3778. modified."
  3779. (when gnus-agent-total-fetched-hashtb
  3780. (gnus-agent-with-refreshed-group
  3781. group
  3782. ;; if null, gnus-agent-group-pathname will calc method.
  3783. (let* ((gnus-command-method method)
  3784. (path (or path (gnus-agent-group-pathname group)))
  3785. (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb)
  3786. (gnus-sethash path (make-list 3 0)
  3787. gnus-agent-total-fetched-hashtb)))
  3788. (file-name-coding-system nnmail-pathname-coding-system)
  3789. (size (or (nth 7 (file-attributes
  3790. (nnheader-concat
  3791. path (if agent-over
  3792. ".overview"
  3793. ".agentview"))))
  3794. 0)))
  3795. (setq gnus-agent-need-update-total-fetched-for t)
  3796. (setf (nth (if agent-over 1 0) entry) size)))))
  3797. (defun gnus-agent-total-fetched-for (group &optional method no-inhibit)
  3798. "Get the total disk space used by the specified GROUP."
  3799. (unless (equal group "dummy.group")
  3800. (unless gnus-agent-total-fetched-hashtb
  3801. (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024)))
  3802. ;; if null, gnus-agent-group-pathname will calc method.
  3803. (let* ((gnus-command-method method)
  3804. (path (gnus-agent-group-pathname group))
  3805. (entry (gnus-gethash path gnus-agent-total-fetched-hashtb)))
  3806. (if entry
  3807. (apply '+ entry)
  3808. (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit)))
  3809. (+
  3810. (gnus-agent-update-view-total-fetched-for group nil method path)
  3811. (gnus-agent-update-view-total-fetched-for group t method path)
  3812. (gnus-agent-update-files-total-fetched-for group nil method path)))))))
  3813. (provide 'gnus-agent)
  3814. ;;; gnus-agent.el ends here